Cope with completely empty lines within the Changes file.
[p5sagit/p5-mst-13.2.git] / toke.c
1 /*    toke.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *   "It all comes from here, the stench and the peril."  --Frodo
13  */
14
15 /*
16  * This file is the lexer for Perl.  It's closely linked to the
17  * parser, perly.y.
18  *
19  * The main routine is yylex(), which returns the next token.
20  */
21
22 #include "EXTERN.h"
23 #define PERL_IN_TOKE_C
24 #include "perl.h"
25
26 #define yychar  (*PL_yycharp)
27 #define yylval  (*PL_yylvalp)
28
29 static const char ident_too_long[] =
30   "Identifier too long";
31 static const char c_without_g[] =
32   "Use of /c modifier is meaningless without /g";
33 static const char c_in_subst[] =
34   "Use of /c modifier is meaningless in s///";
35
36 static void restore_rsfp(pTHX_ void *f);
37 #ifndef PERL_NO_UTF16_FILTER
38 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
39 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
40 #endif
41
42 #define XFAKEBRACK 128
43 #define XENUMMASK 127
44
45 #ifdef USE_UTF8_SCRIPTS
46 #   define UTF (!IN_BYTES)
47 #else
48 #   define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
49 #endif
50
51 /* In variables named $^X, these are the legal values for X.
52  * 1999-02-27 mjd-perl-patch@plover.com */
53 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
54
55 /* On MacOS, respect nonbreaking spaces */
56 #ifdef MACOS_TRADITIONAL
57 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
58 #else
59 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
60 #endif
61
62 /* LEX_* are values for PL_lex_state, the state of the lexer.
63  * They are arranged oddly so that the guard on the switch statement
64  * can get by with a single comparison (if the compiler is smart enough).
65  */
66
67 /* #define LEX_NOTPARSING               11 is done in perl.h. */
68
69 #define LEX_NORMAL              10
70 #define LEX_INTERPNORMAL         9
71 #define LEX_INTERPCASEMOD        8
72 #define LEX_INTERPPUSH           7
73 #define LEX_INTERPSTART          6
74 #define LEX_INTERPEND            5
75 #define LEX_INTERPENDMAYBE       4
76 #define LEX_INTERPCONCAT         3
77 #define LEX_INTERPCONST          2
78 #define LEX_FORMLINE             1
79 #define LEX_KNOWNEXT             0
80
81 #ifdef DEBUGGING
82 static const char* const lex_state_names[] = {
83     "KNOWNEXT",
84     "FORMLINE",
85     "INTERPCONST",
86     "INTERPCONCAT",
87     "INTERPENDMAYBE",
88     "INTERPEND",
89     "INTERPSTART",
90     "INTERPPUSH",
91     "INTERPCASEMOD",
92     "INTERPNORMAL",
93     "NORMAL"
94 };
95 #endif
96
97 #ifdef ff_next
98 #undef ff_next
99 #endif
100
101 #include "keywords.h"
102
103 /* CLINE is a macro that ensures PL_copline has a sane value */
104
105 #ifdef CLINE
106 #undef CLINE
107 #endif
108 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
109
110 /*
111  * Convenience functions to return different tokens and prime the
112  * lexer for the next token.  They all take an argument.
113  *
114  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
115  * OPERATOR     : generic operator
116  * AOPERATOR    : assignment operator
117  * PREBLOCK     : beginning the block after an if, while, foreach, ...
118  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
119  * PREREF       : *EXPR where EXPR is not a simple identifier
120  * TERM         : expression term
121  * LOOPX        : loop exiting command (goto, last, dump, etc)
122  * FTST         : file test operator
123  * FUN0         : zero-argument function
124  * FUN1         : not used, except for not, which isn't a UNIOP
125  * BOop         : bitwise or or xor
126  * BAop         : bitwise and
127  * SHop         : shift operator
128  * PWop         : power operator
129  * PMop         : pattern-matching operator
130  * Aop          : addition-level operator
131  * Mop          : multiplication-level operator
132  * Eop          : equality-testing operator
133  * Rop          : relational operator <= != gt
134  *
135  * Also see LOP and lop() below.
136  */
137
138 #ifdef DEBUGGING /* Serve -DT. */
139 #   define REPORT(retval) tokereport(s,(int)retval)
140 #else
141 #   define REPORT(retval) (retval)
142 #endif
143
144 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
145 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
146 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
147 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
148 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
149 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
150 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
151 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
152 #define FTST(f)  return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
153 #define FUN0(f)  return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
154 #define FUN1(f)  return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
155 #define BOop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
156 #define BAop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
157 #define SHop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
158 #define PWop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
159 #define PMop(f)  return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
160 #define Aop(f)   return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
161 #define Mop(f)   return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
162 #define Eop(f)   return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
163 #define Rop(f)   return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
164
165 /* This bit of chicanery makes a unary function followed by
166  * a parenthesis into a function with one argument, highest precedence.
167  * The UNIDOR macro is for unary functions that can be followed by the //
168  * operator (such as C<shift // 0>).
169  */
170 #define UNI2(f,x) { \
171         yylval.ival = f; \
172         PL_expect = x; \
173         PL_bufptr = s; \
174         PL_last_uni = PL_oldbufptr; \
175         PL_last_lop_op = f; \
176         if (*s == '(') \
177             return REPORT( (int)FUNC1 ); \
178         s = skipspace(s); \
179         return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
180         }
181 #define UNI(f)    UNI2(f,XTERM)
182 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
183
184 #define UNIBRACK(f) { \
185         yylval.ival = f; \
186         PL_bufptr = s; \
187         PL_last_uni = PL_oldbufptr; \
188         if (*s == '(') \
189             return REPORT( (int)FUNC1 ); \
190         s = skipspace(s); \
191         return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
192         }
193
194 /* grandfather return to old style */
195 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
196
197 #ifdef DEBUGGING
198
199 /* how to interpret the yylval associated with the token */
200 enum token_type {
201     TOKENTYPE_NONE,
202     TOKENTYPE_IVAL,
203     TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
204     TOKENTYPE_PVAL,
205     TOKENTYPE_OPVAL,
206     TOKENTYPE_GVVAL
207 };
208
209 static struct debug_tokens { const int token, type; const char *name; }
210   const debug_tokens[] =
211 {
212     { ADDOP,            TOKENTYPE_OPNUM,        "ADDOP" },
213     { ANDAND,           TOKENTYPE_NONE,         "ANDAND" },
214     { ANDOP,            TOKENTYPE_NONE,         "ANDOP" },
215     { ANONSUB,          TOKENTYPE_IVAL,         "ANONSUB" },
216     { ARROW,            TOKENTYPE_NONE,         "ARROW" },
217     { ASSIGNOP,         TOKENTYPE_OPNUM,        "ASSIGNOP" },
218     { BITANDOP,         TOKENTYPE_OPNUM,        "BITANDOP" },
219     { BITOROP,          TOKENTYPE_OPNUM,        "BITOROP" },
220     { COLONATTR,        TOKENTYPE_NONE,         "COLONATTR" },
221     { CONTINUE,         TOKENTYPE_NONE,         "CONTINUE" },
222     { DO,               TOKENTYPE_NONE,         "DO" },
223     { DOLSHARP,         TOKENTYPE_NONE,         "DOLSHARP" },
224     { DORDOR,           TOKENTYPE_NONE,         "DORDOR" },
225     { DOROP,            TOKENTYPE_OPNUM,        "DOROP" },
226     { DOTDOT,           TOKENTYPE_IVAL,         "DOTDOT" },
227     { ELSE,             TOKENTYPE_NONE,         "ELSE" },
228     { ELSIF,            TOKENTYPE_IVAL,         "ELSIF" },
229     { EQOP,             TOKENTYPE_OPNUM,        "EQOP" },
230     { FOR,              TOKENTYPE_IVAL,         "FOR" },
231     { FORMAT,           TOKENTYPE_NONE,         "FORMAT" },
232     { FUNC,             TOKENTYPE_OPNUM,        "FUNC" },
233     { FUNC0,            TOKENTYPE_OPNUM,        "FUNC0" },
234     { FUNC0SUB,         TOKENTYPE_OPVAL,        "FUNC0SUB" },
235     { FUNC1,            TOKENTYPE_OPNUM,        "FUNC1" },
236     { FUNCMETH,         TOKENTYPE_OPVAL,        "FUNCMETH" },
237     { HASHBRACK,        TOKENTYPE_NONE,         "HASHBRACK" },
238     { IF,               TOKENTYPE_IVAL,         "IF" },
239     { LABEL,            TOKENTYPE_PVAL,         "LABEL" },
240     { LOCAL,            TOKENTYPE_IVAL,         "LOCAL" },
241     { LOOPEX,           TOKENTYPE_OPNUM,        "LOOPEX" },
242     { LSTOP,            TOKENTYPE_OPNUM,        "LSTOP" },
243     { LSTOPSUB,         TOKENTYPE_OPVAL,        "LSTOPSUB" },
244     { MATCHOP,          TOKENTYPE_OPNUM,        "MATCHOP" },
245     { METHOD,           TOKENTYPE_OPVAL,        "METHOD" },
246     { MULOP,            TOKENTYPE_OPNUM,        "MULOP" },
247     { MY,               TOKENTYPE_IVAL,         "MY" },
248     { MYSUB,            TOKENTYPE_NONE,         "MYSUB" },
249     { NOAMP,            TOKENTYPE_NONE,         "NOAMP" },
250     { NOTOP,            TOKENTYPE_NONE,         "NOTOP" },
251     { OROP,             TOKENTYPE_IVAL,         "OROP" },
252     { OROR,             TOKENTYPE_NONE,         "OROR" },
253     { PACKAGE,          TOKENTYPE_NONE,         "PACKAGE" },
254     { PMFUNC,           TOKENTYPE_OPVAL,        "PMFUNC" },
255     { POSTDEC,          TOKENTYPE_NONE,         "POSTDEC" },
256     { POSTINC,          TOKENTYPE_NONE,         "POSTINC" },
257     { POWOP,            TOKENTYPE_OPNUM,        "POWOP" },
258     { PREDEC,           TOKENTYPE_NONE,         "PREDEC" },
259     { PREINC,           TOKENTYPE_NONE,         "PREINC" },
260     { PRIVATEREF,       TOKENTYPE_OPVAL,        "PRIVATEREF" },
261     { REFGEN,           TOKENTYPE_NONE,         "REFGEN" },
262     { RELOP,            TOKENTYPE_OPNUM,        "RELOP" },
263     { SHIFTOP,          TOKENTYPE_OPNUM,        "SHIFTOP" },
264     { SUB,              TOKENTYPE_NONE,         "SUB" },
265     { THING,            TOKENTYPE_OPVAL,        "THING" },
266     { UMINUS,           TOKENTYPE_NONE,         "UMINUS" },
267     { UNIOP,            TOKENTYPE_OPNUM,        "UNIOP" },
268     { UNIOPSUB,         TOKENTYPE_OPVAL,        "UNIOPSUB" },
269     { UNLESS,           TOKENTYPE_IVAL,         "UNLESS" },
270     { UNTIL,            TOKENTYPE_IVAL,         "UNTIL" },
271     { USE,              TOKENTYPE_IVAL,         "USE" },
272     { WHILE,            TOKENTYPE_IVAL,         "WHILE" },
273     { WORD,             TOKENTYPE_OPVAL,        "WORD" },
274     { 0,                TOKENTYPE_NONE,         0 }
275 };
276
277 /* dump the returned token in rv, plus any optional arg in yylval */
278
279 STATIC int
280 S_tokereport(pTHX_ const char* s, I32 rv)
281 {
282     if (DEBUG_T_TEST) {
283         const char *name = Nullch;
284         enum token_type type = TOKENTYPE_NONE;
285         const struct debug_tokens *p;
286         SV* const report = newSVpvn("<== ", 4);
287
288         for (p = debug_tokens; p->token; p++) {
289             if (p->token == (int)rv) {
290                 name = p->name;
291                 type = p->type;
292                 break;
293             }
294         }
295         if (name)
296             Perl_sv_catpv(aTHX_ report, name);
297         else if ((char)rv > ' ' && (char)rv < '~')
298             Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
299         else if (!rv)
300             Perl_sv_catpv(aTHX_ report, "EOF");
301         else
302             Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
303         switch (type) {
304         case TOKENTYPE_NONE:
305         case TOKENTYPE_GVVAL: /* doesn't appear to be used */
306             break;
307         case TOKENTYPE_IVAL:
308             Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
309             break;
310         case TOKENTYPE_OPNUM:
311             Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
312                                     PL_op_name[yylval.ival]);
313             break;
314         case TOKENTYPE_PVAL:
315             Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
316             break;
317         case TOKENTYPE_OPVAL:
318             if (yylval.opval)
319                 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
320                                     PL_op_name[yylval.opval->op_type]);
321             else
322                 Perl_sv_catpv(aTHX_ report, "(opval=null)");
323             break;
324         }
325         Perl_sv_catpvf(aTHX_ report, " at line %"IVdf" [", (IV)CopLINE(PL_curcop));
326         if (s - PL_bufptr > 0)
327             sv_catpvn(report, PL_bufptr, s - PL_bufptr);
328         else {
329             if (PL_oldbufptr && *PL_oldbufptr)
330                 sv_catpv(report, PL_tokenbuf);
331         }
332         PerlIO_printf(Perl_debug_log, "### %s]\n", SvPV_nolen_const(report));
333     };
334     return (int)rv;
335 }
336
337 #endif
338
339 /*
340  * S_ao
341  *
342  * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
343  * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
344  */
345
346 STATIC int
347 S_ao(pTHX_ int toketype)
348 {
349     if (*PL_bufptr == '=') {
350         PL_bufptr++;
351         if (toketype == ANDAND)
352             yylval.ival = OP_ANDASSIGN;
353         else if (toketype == OROR)
354             yylval.ival = OP_ORASSIGN;
355         else if (toketype == DORDOR)
356             yylval.ival = OP_DORASSIGN;
357         toketype = ASSIGNOP;
358     }
359     return toketype;
360 }
361
362 /*
363  * S_no_op
364  * When Perl expects an operator and finds something else, no_op
365  * prints the warning.  It always prints "<something> found where
366  * operator expected.  It prints "Missing semicolon on previous line?"
367  * if the surprise occurs at the start of the line.  "do you need to
368  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
369  * where the compiler doesn't know if foo is a method call or a function.
370  * It prints "Missing operator before end of line" if there's nothing
371  * after the missing operator, or "... before <...>" if there is something
372  * after the missing operator.
373  */
374
375 STATIC void
376 S_no_op(pTHX_ const char *what, char *s)
377 {
378     char * const oldbp = PL_bufptr;
379     const bool is_first = (PL_oldbufptr == PL_linestart);
380
381     if (!s)
382         s = oldbp;
383     else
384         PL_bufptr = s;
385     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
386     if (ckWARN_d(WARN_SYNTAX)) {
387         if (is_first)
388             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
389                     "\t(Missing semicolon on previous line?)\n");
390         else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
391             const char *t;
392             for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
393             if (t < PL_bufptr && isSPACE(*t))
394                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
395                         "\t(Do you need to predeclare %.*s?)\n",
396                     t - PL_oldoldbufptr, PL_oldoldbufptr);
397         }
398         else {
399             assert(s >= oldbp);
400             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
401                     "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
402         }
403     }
404     PL_bufptr = oldbp;
405 }
406
407 /*
408  * S_missingterm
409  * Complain about missing quote/regexp/heredoc terminator.
410  * If it's called with (char *)NULL then it cauterizes the line buffer.
411  * If we're in a delimited string and the delimiter is a control
412  * character, it's reformatted into a two-char sequence like ^C.
413  * This is fatal.
414  */
415
416 STATIC void
417 S_missingterm(pTHX_ char *s)
418 {
419     char tmpbuf[3];
420     char q;
421     if (s) {
422         char * const nl = strrchr(s,'\n');
423         if (nl)
424             *nl = '\0';
425     }
426     else if (
427 #ifdef EBCDIC
428         iscntrl(PL_multi_close)
429 #else
430         PL_multi_close < 32 || PL_multi_close == 127
431 #endif
432         ) {
433         *tmpbuf = '^';
434         tmpbuf[1] = toCTRL(PL_multi_close);
435         tmpbuf[2] = '\0';
436         s = tmpbuf;
437     }
438     else {
439         *tmpbuf = (char)PL_multi_close;
440         tmpbuf[1] = '\0';
441         s = tmpbuf;
442     }
443     q = strchr(s,'"') ? '\'' : '"';
444     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
445 }
446
447 /*
448  * Perl_deprecate
449  */
450
451 void
452 Perl_deprecate(pTHX_ const char *s)
453 {
454     if (ckWARN(WARN_DEPRECATED))
455         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
456 }
457
458 void
459 Perl_deprecate_old(pTHX_ const char *s)
460 {
461     /* This function should NOT be called for any new deprecated warnings */
462     /* Use Perl_deprecate instead                                         */
463     /*                                                                    */
464     /* It is here to maintain backward compatibility with the pre-5.8     */
465     /* warnings category hierarchy. The "deprecated" category used to     */
466     /* live under the "syntax" category. It is now a top-level category   */
467     /* in its own right.                                                  */
468
469     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
470         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
471                         "Use of %s is deprecated", s);
472 }
473
474 /*
475  * depcom
476  * Deprecate a comma-less variable list.
477  */
478
479 STATIC void
480 S_depcom(pTHX)
481 {
482     deprecate_old("comma-less variable list");
483 }
484
485 /*
486  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
487  * utf16-to-utf8-reversed.
488  */
489
490 #ifdef PERL_CR_FILTER
491 static void
492 strip_return(SV *sv)
493 {
494     register const char *s = SvPVX_const(sv);
495     register const char * const e = s + SvCUR(sv);
496     /* outer loop optimized to do nothing if there are no CR-LFs */
497     while (s < e) {
498         if (*s++ == '\r' && *s == '\n') {
499             /* hit a CR-LF, need to copy the rest */
500             register char *d = s - 1;
501             *d++ = *s++;
502             while (s < e) {
503                 if (*s == '\r' && s[1] == '\n')
504                     s++;
505                 *d++ = *s++;
506             }
507             SvCUR(sv) -= s - d;
508             return;
509         }
510     }
511 }
512
513 STATIC I32
514 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
515 {
516     const I32 count = FILTER_READ(idx+1, sv, maxlen);
517     if (count > 0 && !maxlen)
518         strip_return(sv);
519     return count;
520 }
521 #endif
522
523 /*
524  * Perl_lex_start
525  * Initialize variables.  Uses the Perl save_stack to save its state (for
526  * recursive calls to the parser).
527  */
528
529 void
530 Perl_lex_start(pTHX_ SV *line)
531 {
532     const char *s;
533     STRLEN len;
534
535     SAVEI32(PL_lex_dojoin);
536     SAVEI32(PL_lex_brackets);
537     SAVEI32(PL_lex_casemods);
538     SAVEI32(PL_lex_starts);
539     SAVEI32(PL_lex_state);
540     SAVEVPTR(PL_lex_inpat);
541     SAVEI32(PL_lex_inwhat);
542     if (PL_lex_state == LEX_KNOWNEXT) {
543         I32 toke = PL_nexttoke;
544         while (--toke >= 0) {
545             SAVEI32(PL_nexttype[toke]);
546             SAVEVPTR(PL_nextval[toke]);
547         }
548         SAVEI32(PL_nexttoke);
549     }
550     SAVECOPLINE(PL_curcop);
551     SAVEPPTR(PL_bufptr);
552     SAVEPPTR(PL_bufend);
553     SAVEPPTR(PL_oldbufptr);
554     SAVEPPTR(PL_oldoldbufptr);
555     SAVEPPTR(PL_last_lop);
556     SAVEPPTR(PL_last_uni);
557     SAVEPPTR(PL_linestart);
558     SAVESPTR(PL_linestr);
559     SAVEGENERICPV(PL_lex_brackstack);
560     SAVEGENERICPV(PL_lex_casestack);
561     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
562     SAVESPTR(PL_lex_stuff);
563     SAVEI32(PL_lex_defer);
564     SAVEI32(PL_sublex_info.sub_inwhat);
565     SAVESPTR(PL_lex_repl);
566     SAVEINT(PL_expect);
567     SAVEINT(PL_lex_expect);
568
569     PL_lex_state = LEX_NORMAL;
570     PL_lex_defer = 0;
571     PL_expect = XSTATE;
572     PL_lex_brackets = 0;
573     Newx(PL_lex_brackstack, 120, char);
574     Newx(PL_lex_casestack, 12, char);
575     PL_lex_casemods = 0;
576     *PL_lex_casestack = '\0';
577     PL_lex_dojoin = 0;
578     PL_lex_starts = 0;
579     PL_lex_stuff = Nullsv;
580     PL_lex_repl = Nullsv;
581     PL_lex_inpat = 0;
582     PL_nexttoke = 0;
583     PL_lex_inwhat = 0;
584     PL_sublex_info.sub_inwhat = 0;
585     PL_linestr = line;
586     if (SvREADONLY(PL_linestr))
587         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
588     s = SvPV_const(PL_linestr, len);
589     if (!len || s[len-1] != ';') {
590         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
591             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
592         sv_catpvn(PL_linestr, "\n;", 2);
593     }
594     SvTEMP_off(PL_linestr);
595     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
596     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
597     PL_last_lop = PL_last_uni = Nullch;
598     PL_rsfp = 0;
599 }
600
601 /*
602  * Perl_lex_end
603  * Finalizer for lexing operations.  Must be called when the parser is
604  * done with the lexer.
605  */
606
607 void
608 Perl_lex_end(pTHX)
609 {
610     PL_doextract = FALSE;
611 }
612
613 /*
614  * S_incline
615  * This subroutine has nothing to do with tilting, whether at windmills
616  * or pinball tables.  Its name is short for "increment line".  It
617  * increments the current line number in CopLINE(PL_curcop) and checks
618  * to see whether the line starts with a comment of the form
619  *    # line 500 "foo.pm"
620  * If so, it sets the current line number and file to the values in the comment.
621  */
622
623 STATIC void
624 S_incline(pTHX_ char *s)
625 {
626     char *t;
627     char *n;
628     char *e;
629     char ch;
630
631     CopLINE_inc(PL_curcop);
632     if (*s++ != '#')
633         return;
634     while (SPACE_OR_TAB(*s)) s++;
635     if (strnEQ(s, "line", 4))
636         s += 4;
637     else
638         return;
639     if (SPACE_OR_TAB(*s))
640         s++;
641     else
642         return;
643     while (SPACE_OR_TAB(*s)) s++;
644     if (!isDIGIT(*s))
645         return;
646     n = s;
647     while (isDIGIT(*s))
648         s++;
649     while (SPACE_OR_TAB(*s))
650         s++;
651     if (*s == '"' && (t = strchr(s+1, '"'))) {
652         s++;
653         e = t + 1;
654     }
655     else {
656         for (t = s; !isSPACE(*t); t++) ;
657         e = t;
658     }
659     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
660         e++;
661     if (*e != '\n' && *e != '\0')
662         return;         /* false alarm */
663
664     ch = *t;
665     *t = '\0';
666     if (t - s > 0) {
667 #ifndef USE_ITHREADS
668         const char *cf = CopFILE(PL_curcop);
669         if (cf && strlen(cf) > 7 && strnEQ(cf, "(eval ", 6)) {
670             /* must copy *{"::_<(eval N)[oldfilename:L]"}
671              * to *{"::_<newfilename"} */
672             char smallbuf[256], smallbuf2[256];
673             char *tmpbuf, *tmpbuf2;
674             GV **gvp, *gv2;
675             STRLEN tmplen = strlen(cf);
676             STRLEN tmplen2 = strlen(s);
677             if (tmplen + 3 < sizeof smallbuf)
678                 tmpbuf = smallbuf;
679             else
680                 Newx(tmpbuf, tmplen + 3, char);
681             if (tmplen2 + 3 < sizeof smallbuf2)
682                 tmpbuf2 = smallbuf2;
683             else
684                 Newx(tmpbuf2, tmplen2 + 3, char);
685             tmpbuf[0] = tmpbuf2[0] = '_';
686             tmpbuf[1] = tmpbuf2[1] = '<';
687             memcpy(tmpbuf + 2, cf, ++tmplen);
688             memcpy(tmpbuf2 + 2, s, ++tmplen2);
689             ++tmplen; ++tmplen2;
690             gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
691             if (gvp) {
692                 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
693                 if (!isGV(gv2))
694                     gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
695                 /* adjust ${"::_<newfilename"} to store the new file name */
696                 GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
697                 GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
698                 GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
699             }
700             if (tmpbuf != smallbuf) Safefree(tmpbuf);
701             if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
702         }
703 #endif
704         CopFILE_free(PL_curcop);
705         CopFILE_set(PL_curcop, s);
706     }
707     *t = ch;
708     CopLINE_set(PL_curcop, atoi(n)-1);
709 }
710
711 /*
712  * S_skipspace
713  * Called to gobble the appropriate amount and type of whitespace.
714  * Skips comments as well.
715  */
716
717 STATIC char *
718 S_skipspace(pTHX_ register char *s)
719 {
720     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
721         while (s < PL_bufend && SPACE_OR_TAB(*s))
722             s++;
723         return s;
724     }
725     for (;;) {
726         STRLEN prevlen;
727         SSize_t oldprevlen, oldoldprevlen;
728         SSize_t oldloplen = 0, oldunilen = 0;
729         while (s < PL_bufend && isSPACE(*s)) {
730             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
731                 incline(s);
732         }
733
734         /* comment */
735         if (s < PL_bufend && *s == '#') {
736             while (s < PL_bufend && *s != '\n')
737                 s++;
738             if (s < PL_bufend) {
739                 s++;
740                 if (PL_in_eval && !PL_rsfp) {
741                     incline(s);
742                     continue;
743                 }
744             }
745         }
746
747         /* only continue to recharge the buffer if we're at the end
748          * of the buffer, we're not reading from a source filter, and
749          * we're in normal lexing mode
750          */
751         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
752                 PL_lex_state == LEX_FORMLINE)
753             return s;
754
755         /* try to recharge the buffer */
756         if ((s = filter_gets(PL_linestr, PL_rsfp,
757                              (prevlen = SvCUR(PL_linestr)))) == Nullch)
758         {
759             /* end of file.  Add on the -p or -n magic */
760             if (PL_minus_p) {
761                 sv_setpv(PL_linestr,
762                          ";}continue{print or die qq(-p destination: $!\\n);}");
763                 PL_minus_n = PL_minus_p = 0;
764             }
765             else if (PL_minus_n) {
766                 sv_setpvn(PL_linestr, ";}", 2);
767                 PL_minus_n = 0;
768             }
769             else
770                 sv_setpvn(PL_linestr,";", 1);
771
772             /* reset variables for next time we lex */
773             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
774                 = SvPVX(PL_linestr);
775             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
776             PL_last_lop = PL_last_uni = Nullch;
777
778             /* Close the filehandle.  Could be from -P preprocessor,
779              * STDIN, or a regular file.  If we were reading code from
780              * STDIN (because the commandline held no -e or filename)
781              * then we don't close it, we reset it so the code can
782              * read from STDIN too.
783              */
784
785             if (PL_preprocess && !PL_in_eval)
786                 (void)PerlProc_pclose(PL_rsfp);
787             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
788                 PerlIO_clearerr(PL_rsfp);
789             else
790                 (void)PerlIO_close(PL_rsfp);
791             PL_rsfp = Nullfp;
792             return s;
793         }
794
795         /* not at end of file, so we only read another line */
796         /* make corresponding updates to old pointers, for yyerror() */
797         oldprevlen = PL_oldbufptr - PL_bufend;
798         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
799         if (PL_last_uni)
800             oldunilen = PL_last_uni - PL_bufend;
801         if (PL_last_lop)
802             oldloplen = PL_last_lop - PL_bufend;
803         PL_linestart = PL_bufptr = s + prevlen;
804         PL_bufend = s + SvCUR(PL_linestr);
805         s = PL_bufptr;
806         PL_oldbufptr = s + oldprevlen;
807         PL_oldoldbufptr = s + oldoldprevlen;
808         if (PL_last_uni)
809             PL_last_uni = s + oldunilen;
810         if (PL_last_lop)
811             PL_last_lop = s + oldloplen;
812         incline(s);
813
814         /* debugger active and we're not compiling the debugger code,
815          * so store the line into the debugger's array of lines
816          */
817         if (PERLDB_LINE && PL_curstash != PL_debstash) {
818             SV * const sv = NEWSV(85,0);
819
820             sv_upgrade(sv, SVt_PVMG);
821             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
822             (void)SvIOK_on(sv);
823             SvIV_set(sv, 0);
824             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
825         }
826     }
827 }
828
829 /*
830  * S_check_uni
831  * Check the unary operators to ensure there's no ambiguity in how they're
832  * used.  An ambiguous piece of code would be:
833  *     rand + 5
834  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
835  * the +5 is its argument.
836  */
837
838 STATIC void
839 S_check_uni(pTHX)
840 {
841     char *s;
842     char *t;
843
844     if (PL_oldoldbufptr != PL_last_uni)
845         return;
846     while (isSPACE(*PL_last_uni))
847         PL_last_uni++;
848     for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
849     if ((t = strchr(s, '(')) && t < PL_bufptr)
850         return;
851     if (ckWARN_d(WARN_AMBIGUOUS)){
852         const char ch = *s;
853         *s = '\0';
854         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
855                    "Warning: Use of \"%s\" without parentheses is ambiguous",
856                    PL_last_uni);
857         *s = ch;
858     }
859 }
860
861 /*
862  * LOP : macro to build a list operator.  Its behaviour has been replaced
863  * with a subroutine, S_lop() for which LOP is just another name.
864  */
865
866 #define LOP(f,x) return lop(f,x,s)
867
868 /*
869  * S_lop
870  * Build a list operator (or something that might be one).  The rules:
871  *  - if we have a next token, then it's a list operator [why?]
872  *  - if the next thing is an opening paren, then it's a function
873  *  - else it's a list operator
874  */
875
876 STATIC I32
877 S_lop(pTHX_ I32 f, int x, char *s)
878 {
879     yylval.ival = f;
880     CLINE;
881     PL_expect = x;
882     PL_bufptr = s;
883     PL_last_lop = PL_oldbufptr;
884     PL_last_lop_op = (OPCODE)f;
885     if (PL_nexttoke)
886         return REPORT(LSTOP);
887     if (*s == '(')
888         return REPORT(FUNC);
889     s = skipspace(s);
890     if (*s == '(')
891         return REPORT(FUNC);
892     else
893         return REPORT(LSTOP);
894 }
895
896 /*
897  * S_force_next
898  * When the lexer realizes it knows the next token (for instance,
899  * it is reordering tokens for the parser) then it can call S_force_next
900  * to know what token to return the next time the lexer is called.  Caller
901  * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
902  * handles the token correctly.
903  */
904
905 STATIC void
906 S_force_next(pTHX_ I32 type)
907 {
908     PL_nexttype[PL_nexttoke] = type;
909     PL_nexttoke++;
910     if (PL_lex_state != LEX_KNOWNEXT) {
911         PL_lex_defer = PL_lex_state;
912         PL_lex_expect = PL_expect;
913         PL_lex_state = LEX_KNOWNEXT;
914     }
915 }
916
917 STATIC SV *
918 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
919 {
920     SV * const sv = newSVpvn(start,len);
921     if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
922         SvUTF8_on(sv);
923     return sv;
924 }
925
926 /*
927  * S_force_word
928  * When the lexer knows the next thing is a word (for instance, it has
929  * just seen -> and it knows that the next char is a word char, then
930  * it calls S_force_word to stick the next word into the PL_next lookahead.
931  *
932  * Arguments:
933  *   char *start : buffer position (must be within PL_linestr)
934  *   int token   : PL_next will be this type of bare word (e.g., METHOD,WORD)
935  *   int check_keyword : if true, Perl checks to make sure the word isn't
936  *       a keyword (do this if the word is a label, e.g. goto FOO)
937  *   int allow_pack : if true, : characters will also be allowed (require,
938  *       use, etc. do this)
939  *   int allow_initial_tick : used by the "sub" lexer only.
940  */
941
942 STATIC char *
943 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
944 {
945     register char *s;
946     STRLEN len;
947
948     start = skipspace(start);
949     s = start;
950     if (isIDFIRST_lazy_if(s,UTF) ||
951         (allow_pack && *s == ':') ||
952         (allow_initial_tick && *s == '\'') )
953     {
954         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
955         if (check_keyword && keyword(PL_tokenbuf, len))
956             return start;
957         if (token == METHOD) {
958             s = skipspace(s);
959             if (*s == '(')
960                 PL_expect = XTERM;
961             else {
962                 PL_expect = XOPERATOR;
963             }
964         }
965         PL_nextval[PL_nexttoke].opval
966             = (OP*)newSVOP(OP_CONST,0,
967                            S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
968         PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
969         force_next(token);
970     }
971     return s;
972 }
973
974 /*
975  * S_force_ident
976  * Called when the lexer wants $foo *foo &foo etc, but the program
977  * text only contains the "foo" portion.  The first argument is a pointer
978  * to the "foo", and the second argument is the type symbol to prefix.
979  * Forces the next token to be a "WORD".
980  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
981  */
982
983 STATIC void
984 S_force_ident(pTHX_ register const char *s, int kind)
985 {
986     if (s && *s) {
987         OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
988         PL_nextval[PL_nexttoke].opval = o;
989         force_next(WORD);
990         if (kind) {
991             o->op_private = OPpCONST_ENTERED;
992             /* XXX see note in pp_entereval() for why we forgo typo
993                warnings if the symbol must be introduced in an eval.
994                GSAR 96-10-12 */
995             gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
996                 kind == '$' ? SVt_PV :
997                 kind == '@' ? SVt_PVAV :
998                 kind == '%' ? SVt_PVHV :
999                               SVt_PVGV
1000                 );
1001         }
1002     }
1003 }
1004
1005 NV
1006 Perl_str_to_version(pTHX_ SV *sv)
1007 {
1008     NV retval = 0.0;
1009     NV nshift = 1.0;
1010     STRLEN len;
1011     const char *start = SvPV_const(sv,len);
1012     const char * const end = start + len;
1013     const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1014     while (start < end) {
1015         STRLEN skip;
1016         UV n;
1017         if (utf)
1018             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1019         else {
1020             n = *(U8*)start;
1021             skip = 1;
1022         }
1023         retval += ((NV)n)/nshift;
1024         start += skip;
1025         nshift *= 1000;
1026     }
1027     return retval;
1028 }
1029
1030 /*
1031  * S_force_version
1032  * Forces the next token to be a version number.
1033  * If the next token appears to be an invalid version number, (e.g. "v2b"),
1034  * and if "guessing" is TRUE, then no new token is created (and the caller
1035  * must use an alternative parsing method).
1036  */
1037
1038 STATIC char *
1039 S_force_version(pTHX_ char *s, int guessing)
1040 {
1041     OP *version = Nullop;
1042     char *d;
1043
1044     s = skipspace(s);
1045
1046     d = s;
1047     if (*d == 'v')
1048         d++;
1049     if (isDIGIT(*d)) {
1050         while (isDIGIT(*d) || *d == '_' || *d == '.')
1051             d++;
1052         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1053             SV *ver;
1054             s = scan_num(s, &yylval);
1055             version = yylval.opval;
1056             ver = cSVOPx(version)->op_sv;
1057             if (SvPOK(ver) && !SvNIOK(ver)) {
1058                 SvUPGRADE(ver, SVt_PVNV);
1059                 SvNV_set(ver, str_to_version(ver));
1060                 SvNOK_on(ver);          /* hint that it is a version */
1061             }
1062         }
1063         else if (guessing)
1064             return s;
1065     }
1066
1067     /* NOTE: The parser sees the package name and the VERSION swapped */
1068     PL_nextval[PL_nexttoke].opval = version;
1069     force_next(WORD);
1070
1071     return s;
1072 }
1073
1074 /*
1075  * S_tokeq
1076  * Tokenize a quoted string passed in as an SV.  It finds the next
1077  * chunk, up to end of string or a backslash.  It may make a new
1078  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
1079  * turns \\ into \.
1080  */
1081
1082 STATIC SV *
1083 S_tokeq(pTHX_ SV *sv)
1084 {
1085     register char *s;
1086     register char *send;
1087     register char *d;
1088     STRLEN len = 0;
1089     SV *pv = sv;
1090
1091     if (!SvLEN(sv))
1092         goto finish;
1093
1094     s = SvPV_force(sv, len);
1095     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1096         goto finish;
1097     send = s + len;
1098     while (s < send && *s != '\\')
1099         s++;
1100     if (s == send)
1101         goto finish;
1102     d = s;
1103     if ( PL_hints & HINT_NEW_STRING ) {
1104         pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1105         if (SvUTF8(sv))
1106             SvUTF8_on(pv);
1107     }
1108     while (s < send) {
1109         if (*s == '\\') {
1110             if (s + 1 < send && (s[1] == '\\'))
1111                 s++;            /* all that, just for this */
1112         }
1113         *d++ = *s++;
1114     }
1115     *d = '\0';
1116     SvCUR_set(sv, d - SvPVX_const(sv));
1117   finish:
1118     if ( PL_hints & HINT_NEW_STRING )
1119        return new_constant(NULL, 0, "q", sv, pv, "q");
1120     return sv;
1121 }
1122
1123 /*
1124  * Now come three functions related to double-quote context,
1125  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
1126  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
1127  * interact with PL_lex_state, and create fake ( ... ) argument lists
1128  * to handle functions and concatenation.
1129  * They assume that whoever calls them will be setting up a fake
1130  * join call, because each subthing puts a ',' after it.  This lets
1131  *   "lower \luPpEr"
1132  * become
1133  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1134  *
1135  * (I'm not sure whether the spurious commas at the end of lcfirst's
1136  * arguments and join's arguments are created or not).
1137  */
1138
1139 /*
1140  * S_sublex_start
1141  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1142  *
1143  * Pattern matching will set PL_lex_op to the pattern-matching op to
1144  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1145  *
1146  * OP_CONST and OP_READLINE are easy--just make the new op and return.
1147  *
1148  * Everything else becomes a FUNC.
1149  *
1150  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1151  * had an OP_CONST or OP_READLINE).  This just sets us up for a
1152  * call to S_sublex_push().
1153  */
1154
1155 STATIC I32
1156 S_sublex_start(pTHX)
1157 {
1158     const register I32 op_type = yylval.ival;
1159
1160     if (op_type == OP_NULL) {
1161         yylval.opval = PL_lex_op;
1162         PL_lex_op = Nullop;
1163         return THING;
1164     }
1165     if (op_type == OP_CONST || op_type == OP_READLINE) {
1166         SV *sv = tokeq(PL_lex_stuff);
1167
1168         if (SvTYPE(sv) == SVt_PVIV) {
1169             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1170             STRLEN len;
1171             const char *p = SvPV_const(sv, len);
1172             SV * const nsv = newSVpvn(p, len);
1173             if (SvUTF8(sv))
1174                 SvUTF8_on(nsv);
1175             SvREFCNT_dec(sv);
1176             sv = nsv;
1177         }
1178         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1179         PL_lex_stuff = Nullsv;
1180         /* Allow <FH> // "foo" */
1181         if (op_type == OP_READLINE)
1182             PL_expect = XTERMORDORDOR;
1183         return THING;
1184     }
1185
1186     PL_sublex_info.super_state = PL_lex_state;
1187     PL_sublex_info.sub_inwhat = op_type;
1188     PL_sublex_info.sub_op = PL_lex_op;
1189     PL_lex_state = LEX_INTERPPUSH;
1190
1191     PL_expect = XTERM;
1192     if (PL_lex_op) {
1193         yylval.opval = PL_lex_op;
1194         PL_lex_op = Nullop;
1195         return PMFUNC;
1196     }
1197     else
1198         return FUNC;
1199 }
1200
1201 /*
1202  * S_sublex_push
1203  * Create a new scope to save the lexing state.  The scope will be
1204  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1205  * to the uc, lc, etc. found before.
1206  * Sets PL_lex_state to LEX_INTERPCONCAT.
1207  */
1208
1209 STATIC I32
1210 S_sublex_push(pTHX)
1211 {
1212     dVAR;
1213     ENTER;
1214
1215     PL_lex_state = PL_sublex_info.super_state;
1216     SAVEI32(PL_lex_dojoin);
1217     SAVEI32(PL_lex_brackets);
1218     SAVEI32(PL_lex_casemods);
1219     SAVEI32(PL_lex_starts);
1220     SAVEI32(PL_lex_state);
1221     SAVEVPTR(PL_lex_inpat);
1222     SAVEI32(PL_lex_inwhat);
1223     SAVECOPLINE(PL_curcop);
1224     SAVEPPTR(PL_bufptr);
1225     SAVEPPTR(PL_bufend);
1226     SAVEPPTR(PL_oldbufptr);
1227     SAVEPPTR(PL_oldoldbufptr);
1228     SAVEPPTR(PL_last_lop);
1229     SAVEPPTR(PL_last_uni);
1230     SAVEPPTR(PL_linestart);
1231     SAVESPTR(PL_linestr);
1232     SAVEGENERICPV(PL_lex_brackstack);
1233     SAVEGENERICPV(PL_lex_casestack);
1234
1235     PL_linestr = PL_lex_stuff;
1236     PL_lex_stuff = Nullsv;
1237
1238     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1239         = SvPVX(PL_linestr);
1240     PL_bufend += SvCUR(PL_linestr);
1241     PL_last_lop = PL_last_uni = Nullch;
1242     SAVEFREESV(PL_linestr);
1243
1244     PL_lex_dojoin = FALSE;
1245     PL_lex_brackets = 0;
1246     Newx(PL_lex_brackstack, 120, char);
1247     Newx(PL_lex_casestack, 12, char);
1248     PL_lex_casemods = 0;
1249     *PL_lex_casestack = '\0';
1250     PL_lex_starts = 0;
1251     PL_lex_state = LEX_INTERPCONCAT;
1252     CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1253
1254     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1255     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1256         PL_lex_inpat = PL_sublex_info.sub_op;
1257     else
1258         PL_lex_inpat = Nullop;
1259
1260     return '(';
1261 }
1262
1263 /*
1264  * S_sublex_done
1265  * Restores lexer state after a S_sublex_push.
1266  */
1267
1268 STATIC I32
1269 S_sublex_done(pTHX)
1270 {
1271     dVAR;
1272     if (!PL_lex_starts++) {
1273         SV * const sv = newSVpvn("",0);
1274         if (SvUTF8(PL_linestr))
1275             SvUTF8_on(sv);
1276         PL_expect = XOPERATOR;
1277         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1278         return THING;
1279     }
1280
1281     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1282         PL_lex_state = LEX_INTERPCASEMOD;
1283         return yylex();
1284     }
1285
1286     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1287     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1288         PL_linestr = PL_lex_repl;
1289         PL_lex_inpat = 0;
1290         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1291         PL_bufend += SvCUR(PL_linestr);
1292         PL_last_lop = PL_last_uni = Nullch;
1293         SAVEFREESV(PL_linestr);
1294         PL_lex_dojoin = FALSE;
1295         PL_lex_brackets = 0;
1296         PL_lex_casemods = 0;
1297         *PL_lex_casestack = '\0';
1298         PL_lex_starts = 0;
1299         if (SvEVALED(PL_lex_repl)) {
1300             PL_lex_state = LEX_INTERPNORMAL;
1301             PL_lex_starts++;
1302             /*  we don't clear PL_lex_repl here, so that we can check later
1303                 whether this is an evalled subst; that means we rely on the
1304                 logic to ensure sublex_done() is called again only via the
1305                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1306         }
1307         else {
1308             PL_lex_state = LEX_INTERPCONCAT;
1309             PL_lex_repl = Nullsv;
1310         }
1311         return ',';
1312     }
1313     else {
1314         LEAVE;
1315         PL_bufend = SvPVX(PL_linestr);
1316         PL_bufend += SvCUR(PL_linestr);
1317         PL_expect = XOPERATOR;
1318         PL_sublex_info.sub_inwhat = 0;
1319         return ')';
1320     }
1321 }
1322
1323 /*
1324   scan_const
1325
1326   Extracts a pattern, double-quoted string, or transliteration.  This
1327   is terrifying code.
1328
1329   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1330   processing a pattern (PL_lex_inpat is true), a transliteration
1331   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1332
1333   Returns a pointer to the character scanned up to. Iff this is
1334   advanced from the start pointer supplied (ie if anything was
1335   successfully parsed), will leave an OP for the substring scanned
1336   in yylval. Caller must intuit reason for not parsing further
1337   by looking at the next characters herself.
1338
1339   In patterns:
1340     backslashes:
1341       double-quoted style: \r and \n
1342       regexp special ones: \D \s
1343       constants: \x3
1344       backrefs: \1 (deprecated in substitution replacements)
1345       case and quoting: \U \Q \E
1346     stops on @ and $, but not for $ as tail anchor
1347
1348   In transliterations:
1349     characters are VERY literal, except for - not at the start or end
1350     of the string, which indicates a range.  scan_const expands the
1351     range to the full set of intermediate characters.
1352
1353   In double-quoted strings:
1354     backslashes:
1355       double-quoted style: \r and \n
1356       constants: \x3
1357       backrefs: \1 (deprecated)
1358       case and quoting: \U \Q \E
1359     stops on @ and $
1360
1361   scan_const does *not* construct ops to handle interpolated strings.
1362   It stops processing as soon as it finds an embedded $ or @ variable
1363   and leaves it to the caller to work out what's going on.
1364
1365   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1366
1367   $ in pattern could be $foo or could be tail anchor.  Assumption:
1368   it's a tail anchor if $ is the last thing in the string, or if it's
1369   followed by one of ")| \n\t"
1370
1371   \1 (backreferences) are turned into $1
1372
1373   The structure of the code is
1374       while (there's a character to process) {
1375           handle transliteration ranges
1376           skip regexp comments
1377           skip # initiated comments in //x patterns
1378           check for embedded @foo
1379           check for embedded scalars
1380           if (backslash) {
1381               leave intact backslashes from leave (below)
1382               deprecate \1 in strings and sub replacements
1383               handle string-changing backslashes \l \U \Q \E, etc.
1384               switch (what was escaped) {
1385                   handle - in a transliteration (becomes a literal -)
1386                   handle \132 octal characters
1387                   handle 0x15 hex characters
1388                   handle \cV (control V)
1389                   handle printf backslashes (\f, \r, \n, etc)
1390               } (end switch)
1391           } (end if backslash)
1392     } (end while character to read)
1393                 
1394 */
1395
1396 STATIC char *
1397 S_scan_const(pTHX_ char *start)
1398 {
1399     register char *send = PL_bufend;            /* end of the constant */
1400     SV *sv = NEWSV(93, send - start);           /* sv for the constant */
1401     register char *s = start;                   /* start of the constant */
1402     register char *d = SvPVX(sv);               /* destination for copies */
1403     bool dorange = FALSE;                       /* are we in a translit range? */
1404     bool didrange = FALSE;                      /* did we just finish a range? */
1405     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1406     I32  this_utf8 = UTF;                       /* The source string is assumed to be UTF8 */
1407     UV uv;
1408 #ifdef EBCDIC
1409     UV literal_endpoint = 0;
1410 #endif
1411
1412     const char *leaveit =       /* set of acceptably-backslashed characters */
1413         PL_lex_inpat
1414             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
1415             : "";
1416
1417     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1418         /* If we are doing a trans and we know we want UTF8 set expectation */
1419         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1420         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1421     }
1422
1423
1424     while (s < send || dorange) {
1425         /* get transliterations out of the way (they're most literal) */
1426         if (PL_lex_inwhat == OP_TRANS) {
1427             /* expand a range A-Z to the full set of characters.  AIE! */
1428             if (dorange) {
1429                 I32 i;                          /* current expanded character */
1430                 I32 min;                        /* first character in range */
1431                 I32 max;                        /* last character in range */
1432
1433                 if (has_utf8) {
1434                     char * const c = (char*)utf8_hop((U8*)d, -1);
1435                     char *e = d++;
1436                     while (e-- > c)
1437                         *(e + 1) = *e;
1438                     *c = (char)UTF_TO_NATIVE(0xff);
1439                     /* mark the range as done, and continue */
1440                     dorange = FALSE;
1441                     didrange = TRUE;
1442                     continue;
1443                 }
1444
1445                 i = d - SvPVX_const(sv);                /* remember current offset */
1446                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1447                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1448                 d -= 2;                         /* eat the first char and the - */
1449
1450                 min = (U8)*d;                   /* first char in range */
1451                 max = (U8)d[1];                 /* last char in range  */
1452
1453                 if (min > max) {
1454                     Perl_croak(aTHX_
1455                                "Invalid range \"%c-%c\" in transliteration operator",
1456                                (char)min, (char)max);
1457                 }
1458
1459 #ifdef EBCDIC
1460                 if (literal_endpoint == 2 &&
1461                     ((isLOWER(min) && isLOWER(max)) ||
1462                      (isUPPER(min) && isUPPER(max)))) {
1463                     if (isLOWER(min)) {
1464                         for (i = min; i <= max; i++)
1465                             if (isLOWER(i))
1466                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1467                     } else {
1468                         for (i = min; i <= max; i++)
1469                             if (isUPPER(i))
1470                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1471                     }
1472                 }
1473                 else
1474 #endif
1475                     for (i = min; i <= max; i++)
1476                         *d++ = (char)i;
1477
1478                 /* mark the range as done, and continue */
1479                 dorange = FALSE;
1480                 didrange = TRUE;
1481 #ifdef EBCDIC
1482                 literal_endpoint = 0;
1483 #endif
1484                 continue;
1485             }
1486
1487             /* range begins (ignore - as first or last char) */
1488             else if (*s == '-' && s+1 < send  && s != start) {
1489                 if (didrange) {
1490                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1491                 }
1492                 if (has_utf8) {
1493                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
1494                     s++;
1495                     continue;
1496                 }
1497                 dorange = TRUE;
1498                 s++;
1499             }
1500             else {
1501                 didrange = FALSE;
1502 #ifdef EBCDIC
1503                 literal_endpoint = 0;
1504 #endif
1505             }
1506         }
1507
1508         /* if we get here, we're not doing a transliteration */
1509
1510         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1511            except for the last char, which will be done separately. */
1512         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1513             if (s[2] == '#') {
1514                 while (s+1 < send && *s != ')')
1515                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1516             }
1517             else if (s[2] == '{' /* This should match regcomp.c */
1518                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1519             {
1520                 I32 count = 1;
1521                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1522                 char c;
1523
1524                 while (count && (c = *regparse)) {
1525                     if (c == '\\' && regparse[1])
1526                         regparse++;
1527                     else if (c == '{')
1528                         count++;
1529                     else if (c == '}')
1530                         count--;
1531                     regparse++;
1532                 }
1533                 if (*regparse != ')')
1534                     regparse--;         /* Leave one char for continuation. */
1535                 while (s < regparse)
1536                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1537             }
1538         }
1539
1540         /* likewise skip #-initiated comments in //x patterns */
1541         else if (*s == '#' && PL_lex_inpat &&
1542           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1543             while (s+1 < send && *s != '\n')
1544                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1545         }
1546
1547         /* check for embedded arrays
1548            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1549            */
1550         else if (*s == '@' && s[1]
1551                  && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1552             break;
1553
1554         /* check for embedded scalars.  only stop if we're sure it's a
1555            variable.
1556         */
1557         else if (*s == '$') {
1558             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1559                 break;
1560             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1561                 break;          /* in regexp, $ might be tail anchor */
1562         }
1563
1564         /* End of else if chain - OP_TRANS rejoin rest */
1565
1566         /* backslashes */
1567         if (*s == '\\' && s+1 < send) {
1568             s++;
1569
1570             /* some backslashes we leave behind */
1571             if (*leaveit && *s && strchr(leaveit, *s)) {
1572                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1573                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1574                 continue;
1575             }
1576
1577             /* deprecate \1 in strings and substitution replacements */
1578             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1579                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1580             {
1581                 if (ckWARN(WARN_SYNTAX))
1582                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1583                 *--s = '$';
1584                 break;
1585             }
1586
1587             /* string-change backslash escapes */
1588             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1589                 --s;
1590                 break;
1591             }
1592
1593             /* if we get here, it's either a quoted -, or a digit */
1594             switch (*s) {
1595
1596             /* quoted - in transliterations */
1597             case '-':
1598                 if (PL_lex_inwhat == OP_TRANS) {
1599                     *d++ = *s++;
1600                     continue;
1601                 }
1602                 /* FALL THROUGH */
1603             default:
1604                 {
1605                     if (isALNUM(*s) &&
1606                         *s != '_' &&
1607                         ckWARN(WARN_MISC))
1608                         Perl_warner(aTHX_ packWARN(WARN_MISC),
1609                                "Unrecognized escape \\%c passed through",
1610                                *s);
1611                     /* default action is to copy the quoted character */
1612                     goto default_action;
1613                 }
1614
1615             /* \132 indicates an octal constant */
1616             case '0': case '1': case '2': case '3':
1617             case '4': case '5': case '6': case '7':
1618                 {
1619                     I32 flags = 0;
1620                     STRLEN len = 3;
1621                     uv = grok_oct(s, &len, &flags, NULL);
1622                     s += len;
1623                 }
1624                 goto NUM_ESCAPE_INSERT;
1625
1626             /* \x24 indicates a hex constant */
1627             case 'x':
1628                 ++s;
1629                 if (*s == '{') {
1630                     char* const e = strchr(s, '}');
1631                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1632                       PERL_SCAN_DISALLOW_PREFIX;
1633                     STRLEN len;
1634
1635                     ++s;
1636                     if (!e) {
1637                         yyerror("Missing right brace on \\x{}");
1638                         continue;
1639                     }
1640                     len = e - s;
1641                     uv = grok_hex(s, &len, &flags, NULL);
1642                     s = e + 1;
1643                 }
1644                 else {
1645                     {
1646                         STRLEN len = 2;
1647                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1648                         uv = grok_hex(s, &len, &flags, NULL);
1649                         s += len;
1650                     }
1651                 }
1652
1653               NUM_ESCAPE_INSERT:
1654                 /* Insert oct or hex escaped character.
1655                  * There will always enough room in sv since such
1656                  * escapes will be longer than any UTF-8 sequence
1657                  * they can end up as. */
1658                 
1659                 /* We need to map to chars to ASCII before doing the tests
1660                    to cover EBCDIC
1661                 */
1662                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1663                     if (!has_utf8 && uv > 255) {
1664                         /* Might need to recode whatever we have
1665                          * accumulated so far if it contains any
1666                          * hibit chars.
1667                          *
1668                          * (Can't we keep track of that and avoid
1669                          *  this rescan? --jhi)
1670                          */
1671                         int hicount = 0;
1672                         U8 *c;
1673                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1674                             if (!NATIVE_IS_INVARIANT(*c)) {
1675                                 hicount++;
1676                             }
1677                         }
1678                         if (hicount) {
1679                             const STRLEN offset = d - SvPVX_const(sv);
1680                             U8 *src, *dst;
1681                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1682                             src = (U8 *)d - 1;
1683                             dst = src+hicount;
1684                             d  += hicount;
1685                             while (src >= (const U8 *)SvPVX_const(sv)) {
1686                                 if (!NATIVE_IS_INVARIANT(*src)) {
1687                                     const U8 ch = NATIVE_TO_ASCII(*src);
1688                                     *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1689                                     *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1690                                 }
1691                                 else {
1692                                     *dst-- = *src;
1693                                 }
1694                                 src--;
1695                             }
1696                         }
1697                     }
1698
1699                     if (has_utf8 || uv > 255) {
1700                         d = (char*)uvchr_to_utf8((U8*)d, uv);
1701                         has_utf8 = TRUE;
1702                         if (PL_lex_inwhat == OP_TRANS &&
1703                             PL_sublex_info.sub_op) {
1704                             PL_sublex_info.sub_op->op_private |=
1705                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
1706                                              : OPpTRANS_TO_UTF);
1707                         }
1708                     }
1709                     else {
1710                         *d++ = (char)uv;
1711                     }
1712                 }
1713                 else {
1714                     *d++ = (char) uv;
1715                 }
1716                 continue;
1717
1718             /* \N{LATIN SMALL LETTER A} is a named character */
1719             case 'N':
1720                 ++s;
1721                 if (*s == '{') {
1722                     char* e = strchr(s, '}');
1723                     SV *res;
1724                     STRLEN len;
1725                     const char *str;
1726
1727                     if (!e) {
1728                         yyerror("Missing right brace on \\N{}");
1729                         e = s - 1;
1730                         goto cont_scan;
1731                     }
1732                     if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1733                         /* \N{U+...} */
1734                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1735                           PERL_SCAN_DISALLOW_PREFIX;
1736                         s += 3;
1737                         len = e - s;
1738                         uv = grok_hex(s, &len, &flags, NULL);
1739                         s = e + 1;
1740                         goto NUM_ESCAPE_INSERT;
1741                     }
1742                     res = newSVpvn(s + 1, e - s - 1);
1743                     res = new_constant( Nullch, 0, "charnames",
1744                                         res, Nullsv, "\\N{...}" );
1745                     if (has_utf8)
1746                         sv_utf8_upgrade(res);
1747                     str = SvPV_const(res,len);
1748 #ifdef EBCDIC_NEVER_MIND
1749                     /* charnames uses pack U and that has been
1750                      * recently changed to do the below uni->native
1751                      * mapping, so this would be redundant (and wrong,
1752                      * the code point would be doubly converted).
1753                      * But leave this in just in case the pack U change
1754                      * gets revoked, but the semantics is still
1755                      * desireable for charnames. --jhi */
1756                     {
1757                          UV uv = utf8_to_uvchr((const U8*)str, 0);
1758
1759                          if (uv < 0x100) {
1760                               U8 tmpbuf[UTF8_MAXBYTES+1], *d;
1761
1762                               d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1763                               sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1764                               str = SvPV_const(res, len);
1765                          }
1766                     }
1767 #endif
1768                     if (!has_utf8 && SvUTF8(res)) {
1769                         const char * const ostart = SvPVX_const(sv);
1770                         SvCUR_set(sv, d - ostart);
1771                         SvPOK_on(sv);
1772                         *d = '\0';
1773                         sv_utf8_upgrade(sv);
1774                         /* this just broke our allocation above... */
1775                         SvGROW(sv, (STRLEN)(send - start));
1776                         d = SvPVX(sv) + SvCUR(sv);
1777                         has_utf8 = TRUE;
1778                     }
1779                     if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1780                         const char * const odest = SvPVX_const(sv);
1781
1782                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1783                         d = SvPVX(sv) + (d - odest);
1784                     }
1785                     Copy(str, d, len, char);
1786                     d += len;
1787                     SvREFCNT_dec(res);
1788                   cont_scan:
1789                     s = e + 1;
1790                 }
1791                 else
1792                     yyerror("Missing braces on \\N{}");
1793                 continue;
1794
1795             /* \c is a control character */
1796             case 'c':
1797                 s++;
1798                 if (s < send) {
1799                     U8 c = *s++;
1800 #ifdef EBCDIC
1801                     if (isLOWER(c))
1802                         c = toUPPER(c);
1803 #endif
1804                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1805                 }
1806                 else {
1807                     yyerror("Missing control char name in \\c");
1808                 }
1809                 continue;
1810
1811             /* printf-style backslashes, formfeeds, newlines, etc */
1812             case 'b':
1813                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1814                 break;
1815             case 'n':
1816                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1817                 break;
1818             case 'r':
1819                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1820                 break;
1821             case 'f':
1822                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1823                 break;
1824             case 't':
1825                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1826                 break;
1827             case 'e':
1828                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1829                 break;
1830             case 'a':
1831                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1832                 break;
1833             } /* end switch */
1834
1835             s++;
1836             continue;
1837         } /* end if (backslash) */
1838 #ifdef EBCDIC
1839         else
1840             literal_endpoint++;
1841 #endif
1842
1843     default_action:
1844         /* If we started with encoded form, or already know we want it
1845            and then encode the next character */
1846         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1847             STRLEN len  = 1;
1848             const UV uv       = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1849             const STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1850             s += len;
1851             if (need > len) {
1852                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1853                 const STRLEN off = d - SvPVX_const(sv);
1854                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1855             }
1856             d = (char*)uvchr_to_utf8((U8*)d, uv);
1857             has_utf8 = TRUE;
1858         }
1859         else {
1860             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1861         }
1862     } /* while loop to process each character */
1863
1864     /* terminate the string and set up the sv */
1865     *d = '\0';
1866     SvCUR_set(sv, d - SvPVX_const(sv));
1867     if (SvCUR(sv) >= SvLEN(sv))
1868         Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1869
1870     SvPOK_on(sv);
1871     if (PL_encoding && !has_utf8) {
1872         sv_recode_to_utf8(sv, PL_encoding);
1873         if (SvUTF8(sv))
1874             has_utf8 = TRUE;
1875     }
1876     if (has_utf8) {
1877         SvUTF8_on(sv);
1878         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1879             PL_sublex_info.sub_op->op_private |=
1880                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1881         }
1882     }
1883
1884     /* shrink the sv if we allocated more than we used */
1885     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1886         SvPV_shrink_to_cur(sv);
1887     }
1888
1889     /* return the substring (via yylval) only if we parsed anything */
1890     if (s > PL_bufptr) {
1891         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1892             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1893                               sv, Nullsv,
1894                               ( PL_lex_inwhat == OP_TRANS
1895                                 ? "tr"
1896                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1897                                     ? "s"
1898                                     : "qq")));
1899         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1900     } else
1901         SvREFCNT_dec(sv);
1902     return s;
1903 }
1904
1905 /* S_intuit_more
1906  * Returns TRUE if there's more to the expression (e.g., a subscript),
1907  * FALSE otherwise.
1908  *
1909  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1910  *
1911  * ->[ and ->{ return TRUE
1912  * { and [ outside a pattern are always subscripts, so return TRUE
1913  * if we're outside a pattern and it's not { or [, then return FALSE
1914  * if we're in a pattern and the first char is a {
1915  *   {4,5} (any digits around the comma) returns FALSE
1916  * if we're in a pattern and the first char is a [
1917  *   [] returns FALSE
1918  *   [SOMETHING] has a funky algorithm to decide whether it's a
1919  *      character class or not.  It has to deal with things like
1920  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1921  * anything else returns TRUE
1922  */
1923
1924 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1925
1926 STATIC int
1927 S_intuit_more(pTHX_ register char *s)
1928 {
1929     if (PL_lex_brackets)
1930         return TRUE;
1931     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1932         return TRUE;
1933     if (*s != '{' && *s != '[')
1934         return FALSE;
1935     if (!PL_lex_inpat)
1936         return TRUE;
1937
1938     /* In a pattern, so maybe we have {n,m}. */
1939     if (*s == '{') {
1940         s++;
1941         if (!isDIGIT(*s))
1942             return TRUE;
1943         while (isDIGIT(*s))
1944             s++;
1945         if (*s == ',')
1946             s++;
1947         while (isDIGIT(*s))
1948             s++;
1949         if (*s == '}')
1950             return FALSE;
1951         return TRUE;
1952         
1953     }
1954
1955     /* On the other hand, maybe we have a character class */
1956
1957     s++;
1958     if (*s == ']' || *s == '^')
1959         return FALSE;
1960     else {
1961         /* this is terrifying, and it works */
1962         int weight = 2;         /* let's weigh the evidence */
1963         char seen[256];
1964         unsigned char un_char = 255, last_un_char;
1965         const char * const send = strchr(s,']');
1966         char tmpbuf[sizeof PL_tokenbuf * 4];
1967
1968         if (!send)              /* has to be an expression */
1969             return TRUE;
1970
1971         Zero(seen,256,char);
1972         if (*s == '$')
1973             weight -= 3;
1974         else if (isDIGIT(*s)) {
1975             if (s[1] != ']') {
1976                 if (isDIGIT(s[1]) && s[2] == ']')
1977                     weight -= 10;
1978             }
1979             else
1980                 weight -= 100;
1981         }
1982         for (; s < send; s++) {
1983             last_un_char = un_char;
1984             un_char = (unsigned char)*s;
1985             switch (*s) {
1986             case '@':
1987             case '&':
1988             case '$':
1989                 weight -= seen[un_char] * 10;
1990                 if (isALNUM_lazy_if(s+1,UTF)) {
1991                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1992                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1993                         weight -= 100;
1994                     else
1995                         weight -= 10;
1996                 }
1997                 else if (*s == '$' && s[1] &&
1998                   strchr("[#!%*<>()-=",s[1])) {
1999                     if (/*{*/ strchr("])} =",s[2]))
2000                         weight -= 10;
2001                     else
2002                         weight -= 1;
2003                 }
2004                 break;
2005             case '\\':
2006                 un_char = 254;
2007                 if (s[1]) {
2008                     if (strchr("wds]",s[1]))
2009                         weight += 100;
2010                     else if (seen['\''] || seen['"'])
2011                         weight += 1;
2012                     else if (strchr("rnftbxcav",s[1]))
2013                         weight += 40;
2014                     else if (isDIGIT(s[1])) {
2015                         weight += 40;
2016                         while (s[1] && isDIGIT(s[1]))
2017                             s++;
2018                     }
2019                 }
2020                 else
2021                     weight += 100;
2022                 break;
2023             case '-':
2024                 if (s[1] == '\\')
2025                     weight += 50;
2026                 if (strchr("aA01! ",last_un_char))
2027                     weight += 30;
2028                 if (strchr("zZ79~",s[1]))
2029                     weight += 30;
2030                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2031                     weight -= 5;        /* cope with negative subscript */
2032                 break;
2033             default:
2034                 if (!isALNUM(last_un_char)
2035                     && !(last_un_char == '$' || last_un_char == '@'
2036                          || last_un_char == '&')
2037                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2038                     char *d = tmpbuf;
2039                     while (isALPHA(*s))
2040                         *d++ = *s++;
2041                     *d = '\0';
2042                     if (keyword(tmpbuf, d - tmpbuf))
2043                         weight -= 150;
2044                 }
2045                 if (un_char == last_un_char + 1)
2046                     weight += 5;
2047                 weight -= seen[un_char];
2048                 break;
2049             }
2050             seen[un_char]++;
2051         }
2052         if (weight >= 0)        /* probably a character class */
2053             return FALSE;
2054     }
2055
2056     return TRUE;
2057 }
2058
2059 /*
2060  * S_intuit_method
2061  *
2062  * Does all the checking to disambiguate
2063  *   foo bar
2064  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
2065  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2066  *
2067  * First argument is the stuff after the first token, e.g. "bar".
2068  *
2069  * Not a method if bar is a filehandle.
2070  * Not a method if foo is a subroutine prototyped to take a filehandle.
2071  * Not a method if it's really "Foo $bar"
2072  * Method if it's "foo $bar"
2073  * Not a method if it's really "print foo $bar"
2074  * Method if it's really "foo package::" (interpreted as package->foo)
2075  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2076  * Not a method if bar is a filehandle or package, but is quoted with
2077  *   =>
2078  */
2079
2080 STATIC int
2081 S_intuit_method(pTHX_ char *start, GV *gv)
2082 {
2083     char *s = start + (*start == '$');
2084     char tmpbuf[sizeof PL_tokenbuf];
2085     STRLEN len;
2086     GV* indirgv;
2087
2088     if (gv) {
2089         CV *cv;
2090         if (GvIO(gv))
2091             return 0;
2092         if ((cv = GvCVu(gv))) {
2093             const char *proto = SvPVX_const(cv);
2094             if (proto) {
2095                 if (*proto == ';')
2096                     proto++;
2097                 if (*proto == '*')
2098                     return 0;
2099             }
2100         } else
2101             gv = 0;
2102     }
2103     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2104     /* start is the beginning of the possible filehandle/object,
2105      * and s is the end of it
2106      * tmpbuf is a copy of it
2107      */
2108
2109     if (*start == '$') {
2110         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2111             return 0;
2112         s = skipspace(s);
2113         PL_bufptr = start;
2114         PL_expect = XREF;
2115         return *s == '(' ? FUNCMETH : METHOD;
2116     }
2117     if (!keyword(tmpbuf, len)) {
2118         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2119             len -= 2;
2120             tmpbuf[len] = '\0';
2121             goto bare_package;
2122         }
2123         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2124         if (indirgv && GvCVu(indirgv))
2125             return 0;
2126         /* filehandle or package name makes it a method */
2127         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2128             s = skipspace(s);
2129             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2130                 return 0;       /* no assumptions -- "=>" quotes bearword */
2131       bare_package:
2132             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
2133                                                    newSVpvn(tmpbuf,len));
2134             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
2135             PL_expect = XTERM;
2136             force_next(WORD);
2137             PL_bufptr = s;
2138             return *s == '(' ? FUNCMETH : METHOD;
2139         }
2140     }
2141     return 0;
2142 }
2143
2144 /*
2145  * S_incl_perldb
2146  * Return a string of Perl code to load the debugger.  If PERL5DB
2147  * is set, it will return the contents of that, otherwise a
2148  * compile-time require of perl5db.pl.
2149  */
2150
2151 STATIC const char*
2152 S_incl_perldb(pTHX)
2153 {
2154     if (PL_perldb) {
2155         const char * const pdb = PerlEnv_getenv("PERL5DB");
2156
2157         if (pdb)
2158             return pdb;
2159         SETERRNO(0,SS_NORMAL);
2160         return "BEGIN { require 'perl5db.pl' }";
2161     }
2162     return "";
2163 }
2164
2165
2166 /* Encoded script support. filter_add() effectively inserts a
2167  * 'pre-processing' function into the current source input stream.
2168  * Note that the filter function only applies to the current source file
2169  * (e.g., it will not affect files 'require'd or 'use'd by this one).
2170  *
2171  * The datasv parameter (which may be NULL) can be used to pass
2172  * private data to this instance of the filter. The filter function
2173  * can recover the SV using the FILTER_DATA macro and use it to
2174  * store private buffers and state information.
2175  *
2176  * The supplied datasv parameter is upgraded to a PVIO type
2177  * and the IoDIRP/IoANY field is used to store the function pointer,
2178  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2179  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2180  * private use must be set using malloc'd pointers.
2181  */
2182
2183 SV *
2184 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2185 {
2186     if (!funcp)
2187         return Nullsv;
2188
2189     if (!PL_rsfp_filters)
2190         PL_rsfp_filters = newAV();
2191     if (!datasv)
2192         datasv = NEWSV(255,0);
2193     SvUPGRADE(datasv, SVt_PVIO);
2194     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2195     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2196     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2197                           IoANY(datasv), SvPV_nolen(datasv)));
2198     av_unshift(PL_rsfp_filters, 1);
2199     av_store(PL_rsfp_filters, 0, datasv) ;
2200     return(datasv);
2201 }
2202
2203
2204 /* Delete most recently added instance of this filter function. */
2205 void
2206 Perl_filter_del(pTHX_ filter_t funcp)
2207 {
2208     SV *datasv;
2209
2210 #ifdef DEBUGGING
2211     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp)));
2212 #endif
2213     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2214         return;
2215     /* if filter is on top of stack (usual case) just pop it off */
2216     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2217     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2218         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2219         IoANY(datasv) = (void *)NULL;
2220         sv_free(av_pop(PL_rsfp_filters));
2221
2222         return;
2223     }
2224     /* we need to search for the correct entry and clear it     */
2225     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2226 }
2227
2228
2229 /* Invoke the idxth filter function for the current rsfp.        */
2230 /* maxlen 0 = read one text line */
2231 I32
2232 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2233 {
2234     filter_t funcp;
2235     SV *datasv = NULL;
2236
2237     if (!PL_rsfp_filters)
2238         return -1;
2239     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
2240         /* Provide a default input filter to make life easy.    */
2241         /* Note that we append to the line. This is handy.      */
2242         DEBUG_P(PerlIO_printf(Perl_debug_log,
2243                               "filter_read %d: from rsfp\n", idx));
2244         if (maxlen) {
2245             /* Want a block */
2246             int len ;
2247             const int old_len = SvCUR(buf_sv);
2248
2249             /* ensure buf_sv is large enough */
2250             SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2251             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2252                 if (PerlIO_error(PL_rsfp))
2253                     return -1;          /* error */
2254                 else
2255                     return 0 ;          /* end of file */
2256             }
2257             SvCUR_set(buf_sv, old_len + len) ;
2258         } else {
2259             /* Want a line */
2260             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2261                 if (PerlIO_error(PL_rsfp))
2262                     return -1;          /* error */
2263                 else
2264                     return 0 ;          /* end of file */
2265             }
2266         }
2267         return SvCUR(buf_sv);
2268     }
2269     /* Skip this filter slot if filter has been deleted */
2270     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2271         DEBUG_P(PerlIO_printf(Perl_debug_log,
2272                               "filter_read %d: skipped (filter deleted)\n",
2273                               idx));
2274         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2275     }
2276     /* Get function pointer hidden within datasv        */
2277     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2278     DEBUG_P(PerlIO_printf(Perl_debug_log,
2279                           "filter_read %d: via function %p (%s)\n",
2280                           idx, datasv, SvPV_nolen_const(datasv)));
2281     /* Call function. The function is expected to       */
2282     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2283     /* Return: <0:error, =0:eof, >0:not eof             */
2284     return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2285 }
2286
2287 STATIC char *
2288 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2289 {
2290 #ifdef PERL_CR_FILTER
2291     if (!PL_rsfp_filters) {
2292         filter_add(S_cr_textfilter,NULL);
2293     }
2294 #endif
2295     if (PL_rsfp_filters) {
2296         if (!append)
2297             SvCUR_set(sv, 0);   /* start with empty line        */
2298         if (FILTER_READ(0, sv, 0) > 0)
2299             return ( SvPVX(sv) ) ;
2300         else
2301             return Nullch ;
2302     }
2303     else
2304         return (sv_gets(sv, fp, append));
2305 }
2306
2307 STATIC HV *
2308 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2309 {
2310     GV *gv;
2311
2312     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2313         return PL_curstash;
2314
2315     if (len > 2 &&
2316         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2317         (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2318     {
2319         return GvHV(gv);                        /* Foo:: */
2320     }
2321
2322     /* use constant CLASS => 'MyClass' */
2323     if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2324         SV *sv;
2325         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2326             pkgname = SvPV_nolen_const(sv);
2327         }
2328     }
2329
2330     return gv_stashpv(pkgname, FALSE);
2331 }
2332
2333 STATIC char *
2334 S_tokenize_use(pTHX_ int is_use, char *s) {
2335     if (PL_expect != XSTATE)
2336         yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
2337                     is_use ? "use" : "no"));
2338     s = skipspace(s);
2339     if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
2340         s = force_version(s, TRUE);
2341         if (*s == ';' || (s = skipspace(s), *s == ';')) {
2342             PL_nextval[PL_nexttoke].opval = Nullop;
2343             force_next(WORD);
2344         }
2345         else if (*s == 'v') {
2346             s = force_word(s,WORD,FALSE,TRUE,FALSE);
2347             s = force_version(s, FALSE);
2348         }
2349     }
2350     else {
2351         s = force_word(s,WORD,FALSE,TRUE,FALSE);
2352         s = force_version(s, FALSE);
2353     }
2354     yylval.ival = is_use;
2355     return s;
2356 }
2357 #ifdef DEBUGGING
2358     static const char* const exp_name[] =
2359         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2360           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2361         };
2362 #endif
2363
2364 /*
2365   yylex
2366
2367   Works out what to call the token just pulled out of the input
2368   stream.  The yacc parser takes care of taking the ops we return and
2369   stitching them into a tree.
2370
2371   Returns:
2372     PRIVATEREF
2373
2374   Structure:
2375       if read an identifier
2376           if we're in a my declaration
2377               croak if they tried to say my($foo::bar)
2378               build the ops for a my() declaration
2379           if it's an access to a my() variable
2380               are we in a sort block?
2381                   croak if my($a); $a <=> $b
2382               build ops for access to a my() variable
2383           if in a dq string, and they've said @foo and we can't find @foo
2384               croak
2385           build ops for a bareword
2386       if we already built the token before, use it.
2387 */
2388
2389
2390 #ifdef __SC__
2391 #pragma segment Perl_yylex
2392 #endif
2393 int
2394 Perl_yylex(pTHX)
2395 {
2396     register char *s = PL_bufptr;
2397     register char *d;
2398     register I32 tmp;
2399     STRLEN len;
2400     GV *gv = Nullgv;
2401     GV **gvp = 0;
2402     bool bof = FALSE;
2403     I32 orig_keyword = 0;
2404
2405     DEBUG_T( {
2406         PerlIO_printf(Perl_debug_log, "### LEX_%s\n",
2407                                         lex_state_names[PL_lex_state]);
2408     } );
2409     /* check if there's an identifier for us to look at */
2410     if (PL_pending_ident)
2411         return REPORT(S_pending_ident(aTHX));
2412
2413     /* no identifier pending identification */
2414
2415     switch (PL_lex_state) {
2416 #ifdef COMMENTARY
2417     case LEX_NORMAL:            /* Some compilers will produce faster */
2418     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2419         break;
2420 #endif
2421
2422     /* when we've already built the next token, just pull it out of the queue */
2423     case LEX_KNOWNEXT:
2424         PL_nexttoke--;
2425         yylval = PL_nextval[PL_nexttoke];
2426         if (!PL_nexttoke) {
2427             PL_lex_state = PL_lex_defer;
2428             PL_expect = PL_lex_expect;
2429             PL_lex_defer = LEX_NORMAL;
2430         }
2431         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2432               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2433               (IV)PL_nexttype[PL_nexttoke]); });
2434
2435         return REPORT(PL_nexttype[PL_nexttoke]);
2436
2437     /* interpolated case modifiers like \L \U, including \Q and \E.
2438        when we get here, PL_bufptr is at the \
2439     */
2440     case LEX_INTERPCASEMOD:
2441 #ifdef DEBUGGING
2442         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2443             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2444 #endif
2445         /* handle \E or end of string */
2446         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2447             /* if at a \E */
2448             if (PL_lex_casemods) {
2449                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
2450                 PL_lex_casestack[PL_lex_casemods] = '\0';
2451
2452                 if (PL_bufptr != PL_bufend
2453                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
2454                     PL_bufptr += 2;
2455                     PL_lex_state = LEX_INTERPCONCAT;
2456                 }
2457                 return REPORT(')');
2458             }
2459             if (PL_bufptr != PL_bufend)
2460                 PL_bufptr += 2;
2461             PL_lex_state = LEX_INTERPCONCAT;
2462             return yylex();
2463         }
2464         else {
2465             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2466               "### Saw case modifier at '%s'\n", PL_bufptr); });
2467             s = PL_bufptr + 1;
2468             if (s[1] == '\\' && s[2] == 'E') {
2469                 PL_bufptr = s + 3;
2470                 PL_lex_state = LEX_INTERPCONCAT;
2471                 return yylex();
2472             }
2473             else {
2474                 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2475                     tmp = *s, *s = s[2], s[2] = (char)tmp;      /* misordered... */
2476                 if ((*s == 'L' || *s == 'U') &&
2477                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2478                     PL_lex_casestack[--PL_lex_casemods] = '\0';
2479                     return REPORT(')');
2480                 }
2481                 if (PL_lex_casemods > 10)
2482                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2483                 PL_lex_casestack[PL_lex_casemods++] = *s;
2484                 PL_lex_casestack[PL_lex_casemods] = '\0';
2485                 PL_lex_state = LEX_INTERPCONCAT;
2486                 PL_nextval[PL_nexttoke].ival = 0;
2487                 force_next('(');
2488                 if (*s == 'l')
2489                     PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2490                 else if (*s == 'u')
2491                     PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2492                 else if (*s == 'L')
2493                     PL_nextval[PL_nexttoke].ival = OP_LC;
2494                 else if (*s == 'U')
2495                     PL_nextval[PL_nexttoke].ival = OP_UC;
2496                 else if (*s == 'Q')
2497                     PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2498                 else
2499                     Perl_croak(aTHX_ "panic: yylex");
2500                 PL_bufptr = s + 1;
2501             }
2502             force_next(FUNC);
2503             if (PL_lex_starts) {
2504                 s = PL_bufptr;
2505                 PL_lex_starts = 0;
2506                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2507                 if (PL_lex_casemods == 1 && PL_lex_inpat)
2508                     OPERATOR(',');
2509                 else
2510                     Aop(OP_CONCAT);
2511             }
2512             else
2513                 return yylex();
2514         }
2515
2516     case LEX_INTERPPUSH:
2517         return REPORT(sublex_push());
2518
2519     case LEX_INTERPSTART:
2520         if (PL_bufptr == PL_bufend)
2521             return REPORT(sublex_done());
2522         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2523               "### Interpolated variable at '%s'\n", PL_bufptr); });
2524         PL_expect = XTERM;
2525         PL_lex_dojoin = (*PL_bufptr == '@');
2526         PL_lex_state = LEX_INTERPNORMAL;
2527         if (PL_lex_dojoin) {
2528             PL_nextval[PL_nexttoke].ival = 0;
2529             force_next(',');
2530             force_ident("\"", '$');
2531             PL_nextval[PL_nexttoke].ival = 0;
2532             force_next('$');
2533             PL_nextval[PL_nexttoke].ival = 0;
2534             force_next('(');
2535             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2536             force_next(FUNC);
2537         }
2538         if (PL_lex_starts++) {
2539             s = PL_bufptr;
2540             /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2541             if (!PL_lex_casemods && PL_lex_inpat)
2542                 OPERATOR(',');
2543             else
2544                 Aop(OP_CONCAT);
2545         }
2546         return yylex();
2547
2548     case LEX_INTERPENDMAYBE:
2549         if (intuit_more(PL_bufptr)) {
2550             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2551             break;
2552         }
2553         /* FALL THROUGH */
2554
2555     case LEX_INTERPEND:
2556         if (PL_lex_dojoin) {
2557             PL_lex_dojoin = FALSE;
2558             PL_lex_state = LEX_INTERPCONCAT;
2559             return REPORT(')');
2560         }
2561         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2562             && SvEVALED(PL_lex_repl))
2563         {
2564             if (PL_bufptr != PL_bufend)
2565                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2566             PL_lex_repl = Nullsv;
2567         }
2568         /* FALLTHROUGH */
2569     case LEX_INTERPCONCAT:
2570 #ifdef DEBUGGING
2571         if (PL_lex_brackets)
2572             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2573 #endif
2574         if (PL_bufptr == PL_bufend)
2575             return REPORT(sublex_done());
2576
2577         if (SvIVX(PL_linestr) == '\'') {
2578             SV *sv = newSVsv(PL_linestr);
2579             if (!PL_lex_inpat)
2580                 sv = tokeq(sv);
2581             else if ( PL_hints & HINT_NEW_RE )
2582                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2583             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2584             s = PL_bufend;
2585         }
2586         else {
2587             s = scan_const(PL_bufptr);
2588             if (*s == '\\')
2589                 PL_lex_state = LEX_INTERPCASEMOD;
2590             else
2591                 PL_lex_state = LEX_INTERPSTART;
2592         }
2593
2594         if (s != PL_bufptr) {
2595             PL_nextval[PL_nexttoke] = yylval;
2596             PL_expect = XTERM;
2597             force_next(THING);
2598             if (PL_lex_starts++) {
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             else {
2606                 PL_bufptr = s;
2607                 return yylex();
2608             }
2609         }
2610
2611         return yylex();
2612     case LEX_FORMLINE:
2613         PL_lex_state = LEX_NORMAL;
2614         s = scan_formline(PL_bufptr);
2615         if (!PL_lex_formbrack)
2616             goto rightbracket;
2617         OPERATOR(';');
2618     }
2619
2620     s = PL_bufptr;
2621     PL_oldoldbufptr = PL_oldbufptr;
2622     PL_oldbufptr = s;
2623     DEBUG_T( {
2624         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n",
2625                       exp_name[PL_expect], s);
2626     } );
2627
2628   retry:
2629     switch (*s) {
2630     default:
2631         if (isIDFIRST_lazy_if(s,UTF))
2632             goto keylookup;
2633         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2634     case 4:
2635     case 26:
2636         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2637     case 0:
2638         if (!PL_rsfp) {
2639             PL_last_uni = 0;
2640             PL_last_lop = 0;
2641             if (PL_lex_brackets) {
2642                 if (PL_lex_formbrack)
2643                     yyerror("Format not terminated");
2644                 else
2645                     yyerror("Missing right curly or square bracket");
2646             }
2647             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2648                         "### Tokener got EOF\n");
2649             } );
2650             TOKEN(0);
2651         }
2652         if (s++ < PL_bufend)
2653             goto retry;                 /* ignore stray nulls */
2654         PL_last_uni = 0;
2655         PL_last_lop = 0;
2656         if (!PL_in_eval && !PL_preambled) {
2657             PL_preambled = TRUE;
2658             sv_setpv(PL_linestr,incl_perldb());
2659             if (SvCUR(PL_linestr))
2660                 sv_catpvn(PL_linestr,";", 1);
2661             if (PL_preambleav){
2662                 while(AvFILLp(PL_preambleav) >= 0) {
2663                     SV *tmpsv = av_shift(PL_preambleav);
2664                     sv_catsv(PL_linestr, tmpsv);
2665                     sv_catpvn(PL_linestr, ";", 1);
2666                     sv_free(tmpsv);
2667                 }
2668                 sv_free((SV*)PL_preambleav);
2669                 PL_preambleav = NULL;
2670             }
2671             if (PL_minus_n || PL_minus_p) {
2672                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2673                 if (PL_minus_l)
2674                     sv_catpv(PL_linestr,"chomp;");
2675                 if (PL_minus_a) {
2676                     if (PL_minus_F) {
2677                         if ((*PL_splitstr == '/' || *PL_splitstr == '\''
2678                              || *PL_splitstr == '"')
2679                               && strchr(PL_splitstr + 1, *PL_splitstr))
2680                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2681                         else {
2682                             /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
2683                                bytes can be used as quoting characters.  :-) */
2684                             /* The count here deliberately includes the NUL
2685                                that terminates the C string constant.  This
2686                                embeds the opening NUL into the string.  */
2687                             const char *splits = PL_splitstr;
2688                             sv_catpvn(PL_linestr, "our @F=split(q", 15);
2689                             do {
2690                                 /* Need to \ \s  */
2691                                 if (*splits == '\\')
2692                                     sv_catpvn(PL_linestr, splits, 1);
2693                                 sv_catpvn(PL_linestr, splits, 1);
2694                             } while (*splits++);
2695                             /* This loop will embed the trailing NUL of
2696                                PL_linestr as the last thing it does before
2697                                terminating.  */
2698                             sv_catpvn(PL_linestr, ");", 2);
2699                         }
2700                     }
2701                     else
2702                         sv_catpv(PL_linestr,"our @F=split(' ');");
2703                 }
2704             }
2705             sv_catpvn(PL_linestr, "\n", 1);
2706             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2707             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2708             PL_last_lop = PL_last_uni = Nullch;
2709             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2710                 SV * const sv = NEWSV(85,0);
2711
2712                 sv_upgrade(sv, SVt_PVMG);
2713                 sv_setsv(sv,PL_linestr);
2714                 (void)SvIOK_on(sv);
2715                 SvIV_set(sv, 0);
2716                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2717             }
2718             goto retry;
2719         }
2720         do {
2721             bof = PL_rsfp ? TRUE : FALSE;
2722             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2723               fake_eof:
2724                 if (PL_rsfp) {
2725                     if (PL_preprocess && !PL_in_eval)
2726                         (void)PerlProc_pclose(PL_rsfp);
2727                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2728                         PerlIO_clearerr(PL_rsfp);
2729                     else
2730                         (void)PerlIO_close(PL_rsfp);
2731                     PL_rsfp = Nullfp;
2732                     PL_doextract = FALSE;
2733                 }
2734                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2735                     sv_setpv(PL_linestr,PL_minus_p
2736                              ? ";}continue{print;}" : ";}");
2737                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2738                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2739                     PL_last_lop = PL_last_uni = Nullch;
2740                     PL_minus_n = PL_minus_p = 0;
2741                     goto retry;
2742                 }
2743                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2744                 PL_last_lop = PL_last_uni = Nullch;
2745                 sv_setpvn(PL_linestr,"",0);
2746                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2747             }
2748             /* If it looks like the start of a BOM or raw UTF-16,
2749              * check if it in fact is. */
2750             else if (bof &&
2751                      (*s == 0 ||
2752                       *(U8*)s == 0xEF ||
2753                       *(U8*)s >= 0xFE ||
2754                       s[1] == 0)) {
2755 #ifdef PERLIO_IS_STDIO
2756 #  ifdef __GNU_LIBRARY__
2757 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2758 #      define FTELL_FOR_PIPE_IS_BROKEN
2759 #    endif
2760 #  else
2761 #    ifdef __GLIBC__
2762 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2763 #        define FTELL_FOR_PIPE_IS_BROKEN
2764 #      endif
2765 #    endif
2766 #  endif
2767 #endif
2768 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2769                 /* This loses the possibility to detect the bof
2770                  * situation on perl -P when the libc5 is being used.
2771                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2772                  */
2773                 if (!PL_preprocess)
2774                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2775 #else
2776                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2777 #endif
2778                 if (bof) {
2779                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2780                     s = swallow_bom((U8*)s);
2781                 }
2782             }
2783             if (PL_doextract) {
2784                 /* Incest with pod. */
2785                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2786                     sv_setpvn(PL_linestr, "", 0);
2787                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2788                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2789                     PL_last_lop = PL_last_uni = Nullch;
2790                     PL_doextract = FALSE;
2791                 }
2792             }
2793             incline(s);
2794         } while (PL_doextract);
2795         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2796         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2797             SV * const sv = NEWSV(85,0);
2798
2799             sv_upgrade(sv, SVt_PVMG);
2800             sv_setsv(sv,PL_linestr);
2801             (void)SvIOK_on(sv);
2802             SvIV_set(sv, 0);
2803             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2804         }
2805         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2806         PL_last_lop = PL_last_uni = Nullch;
2807         if (CopLINE(PL_curcop) == 1) {
2808             while (s < PL_bufend && isSPACE(*s))
2809                 s++;
2810             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2811                 s++;
2812             d = Nullch;
2813             if (!PL_in_eval) {
2814                 if (*s == '#' && *(s+1) == '!')
2815                     d = s + 2;
2816 #ifdef ALTERNATE_SHEBANG
2817                 else {
2818                     static char const as[] = ALTERNATE_SHEBANG;
2819                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2820                         d = s + (sizeof(as) - 1);
2821                 }
2822 #endif /* ALTERNATE_SHEBANG */
2823             }
2824             if (d) {
2825                 char *ipath;
2826                 char *ipathend;
2827
2828                 while (isSPACE(*d))
2829                     d++;
2830                 ipath = d;
2831                 while (*d && !isSPACE(*d))
2832                     d++;
2833                 ipathend = d;
2834
2835 #ifdef ARG_ZERO_IS_SCRIPT
2836                 if (ipathend > ipath) {
2837                     /*
2838                      * HP-UX (at least) sets argv[0] to the script name,
2839                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2840                      * at least, set argv[0] to the basename of the Perl
2841                      * interpreter. So, having found "#!", we'll set it right.
2842                      */
2843                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2844                     assert(SvPOK(x) || SvGMAGICAL(x));
2845                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2846                         sv_setpvn(x, ipath, ipathend - ipath);
2847                         SvSETMAGIC(x);
2848                     }
2849                     else {
2850                         STRLEN blen;
2851                         STRLEN llen;
2852                         const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
2853                         const char * const lstart = SvPV_const(x,llen);
2854                         if (llen < blen) {
2855                             bstart += blen - llen;
2856                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2857                                 sv_setpvn(x, ipath, ipathend - ipath);
2858                                 SvSETMAGIC(x);
2859                             }
2860                         }
2861                     }
2862                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2863                 }
2864 #endif /* ARG_ZERO_IS_SCRIPT */
2865
2866                 /*
2867                  * Look for options.
2868                  */
2869                 d = instr(s,"perl -");
2870                 if (!d) {
2871                     d = instr(s,"perl");
2872 #if defined(DOSISH)
2873                     /* avoid getting into infinite loops when shebang
2874                      * line contains "Perl" rather than "perl" */
2875                     if (!d) {
2876                         for (d = ipathend-4; d >= ipath; --d) {
2877                             if ((*d == 'p' || *d == 'P')
2878                                 && !ibcmp(d, "perl", 4))
2879                             {
2880                                 break;
2881                             }
2882                         }
2883                         if (d < ipath)
2884                             d = Nullch;
2885                     }
2886 #endif
2887                 }
2888 #ifdef ALTERNATE_SHEBANG
2889                 /*
2890                  * If the ALTERNATE_SHEBANG on this system starts with a
2891                  * character that can be part of a Perl expression, then if
2892                  * we see it but not "perl", we're probably looking at the
2893                  * start of Perl code, not a request to hand off to some
2894                  * other interpreter.  Similarly, if "perl" is there, but
2895                  * not in the first 'word' of the line, we assume the line
2896                  * contains the start of the Perl program.
2897                  */
2898                 if (d && *s != '#') {
2899                     const char *c = ipath;
2900                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2901                         c++;
2902                     if (c < d)
2903                         d = Nullch;     /* "perl" not in first word; ignore */
2904                     else
2905                         *s = '#';       /* Don't try to parse shebang line */
2906                 }
2907 #endif /* ALTERNATE_SHEBANG */
2908 #ifndef MACOS_TRADITIONAL
2909                 if (!d &&
2910                     *s == '#' &&
2911                     ipathend > ipath &&
2912                     !PL_minus_c &&
2913                     !instr(s,"indir") &&
2914                     instr(PL_origargv[0],"perl"))
2915                 {
2916                     dVAR;
2917                     char **newargv;
2918
2919                     *ipathend = '\0';
2920                     s = ipathend + 1;
2921                     while (s < PL_bufend && isSPACE(*s))
2922                         s++;
2923                     if (s < PL_bufend) {
2924                         Newxz(newargv,PL_origargc+3,char*);
2925                         newargv[1] = s;
2926                         while (s < PL_bufend && !isSPACE(*s))
2927                             s++;
2928                         *s = '\0';
2929                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2930                     }
2931                     else
2932                         newargv = PL_origargv;
2933                     newargv[0] = ipath;
2934                     PERL_FPU_PRE_EXEC
2935                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2936                     PERL_FPU_POST_EXEC
2937                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2938                 }
2939 #endif
2940                 if (d) {
2941                     const U32 oldpdb = PL_perldb;
2942                     const bool oldn = PL_minus_n;
2943                     const bool oldp = PL_minus_p;
2944
2945                     while (*d && !isSPACE(*d)) d++;
2946                     while (SPACE_OR_TAB(*d)) d++;
2947
2948                     if (*d++ == '-') {
2949                         const bool switches_done = PL_doswitches;
2950                         do {
2951                             if (*d == 'M' || *d == 'm' || *d == 'C') {
2952                                 const char * const m = d;
2953                                 while (*d && !isSPACE(*d)) d++;
2954                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2955                                       (int)(d - m), m);
2956                             }
2957                             d = moreswitches(d);
2958                         } while (d);
2959                         if (PL_doswitches && !switches_done) {
2960                             int argc = PL_origargc;
2961                             char **argv = PL_origargv;
2962                             do {
2963                                 argc--,argv++;
2964                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2965                             init_argv_symbols(argc,argv);
2966                         }
2967                         if ((PERLDB_LINE && !oldpdb) ||
2968                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2969                               /* if we have already added "LINE: while (<>) {",
2970                                  we must not do it again */
2971                         {
2972                             sv_setpvn(PL_linestr, "", 0);
2973                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2974                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2975                             PL_last_lop = PL_last_uni = Nullch;
2976                             PL_preambled = FALSE;
2977                             if (PERLDB_LINE)
2978                                 (void)gv_fetchfile(PL_origfilename);
2979                             goto retry;
2980                         }
2981                         if (PL_doswitches && !switches_done) {
2982                             int argc = PL_origargc;
2983                             char **argv = PL_origargv;
2984                             do {
2985                                 argc--,argv++;
2986                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2987                             init_argv_symbols(argc,argv);
2988                         }
2989                     }
2990                 }
2991             }
2992         }
2993         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2994             PL_bufptr = s;
2995             PL_lex_state = LEX_FORMLINE;
2996             return yylex();
2997         }
2998         goto retry;
2999     case '\r':
3000 #ifdef PERL_STRICT_CR
3001         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3002         Perl_croak(aTHX_
3003       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3004 #endif
3005     case ' ': case '\t': case '\f': case 013:
3006 #ifdef MACOS_TRADITIONAL
3007     case '\312':
3008 #endif
3009         s++;
3010         goto retry;
3011     case '#':
3012     case '\n':
3013         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3014             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3015                 /* handle eval qq[#line 1 "foo"\n ...] */
3016                 CopLINE_dec(PL_curcop);
3017                 incline(s);
3018             }
3019             d = PL_bufend;
3020             while (s < d && *s != '\n')
3021                 s++;
3022             if (s < d)
3023                 s++;
3024             else if (s > d) /* Found by Ilya: feed random input to Perl. */
3025               Perl_croak(aTHX_ "panic: input overflow");
3026             incline(s);
3027             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3028                 PL_bufptr = s;
3029                 PL_lex_state = LEX_FORMLINE;
3030                 return yylex();
3031             }
3032         }
3033         else {
3034             *s = '\0';
3035             PL_bufend = s;
3036         }
3037         goto retry;
3038     case '-':
3039         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3040             I32 ftst = 0;
3041
3042             s++;
3043             PL_bufptr = s;
3044             tmp = *s++;
3045
3046             while (s < PL_bufend && SPACE_OR_TAB(*s))
3047                 s++;
3048
3049             if (strnEQ(s,"=>",2)) {
3050                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3051                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3052                             "### Saw unary minus before =>, forcing word '%s'\n", s);
3053                 } );
3054                 OPERATOR('-');          /* unary minus */
3055             }
3056             PL_last_uni = PL_oldbufptr;
3057             switch (tmp) {
3058             case 'r': ftst = OP_FTEREAD;        break;
3059             case 'w': ftst = OP_FTEWRITE;       break;
3060             case 'x': ftst = OP_FTEEXEC;        break;
3061             case 'o': ftst = OP_FTEOWNED;       break;
3062             case 'R': ftst = OP_FTRREAD;        break;
3063             case 'W': ftst = OP_FTRWRITE;       break;
3064             case 'X': ftst = OP_FTREXEC;        break;
3065             case 'O': ftst = OP_FTROWNED;       break;
3066             case 'e': ftst = OP_FTIS;           break;
3067             case 'z': ftst = OP_FTZERO;         break;
3068             case 's': ftst = OP_FTSIZE;         break;
3069             case 'f': ftst = OP_FTFILE;         break;
3070             case 'd': ftst = OP_FTDIR;          break;
3071             case 'l': ftst = OP_FTLINK;         break;
3072             case 'p': ftst = OP_FTPIPE;         break;
3073             case 'S': ftst = OP_FTSOCK;         break;
3074             case 'u': ftst = OP_FTSUID;         break;
3075             case 'g': ftst = OP_FTSGID;         break;
3076             case 'k': ftst = OP_FTSVTX;         break;
3077             case 'b': ftst = OP_FTBLK;          break;
3078             case 'c': ftst = OP_FTCHR;          break;
3079             case 't': ftst = OP_FTTTY;          break;
3080             case 'T': ftst = OP_FTTEXT;         break;
3081             case 'B': ftst = OP_FTBINARY;       break;
3082             case 'M': case 'A': case 'C':
3083                 gv_fetchpv("\024",TRUE, SVt_PV);
3084                 switch (tmp) {
3085                 case 'M': ftst = OP_FTMTIME;    break;
3086                 case 'A': ftst = OP_FTATIME;    break;
3087                 case 'C': ftst = OP_FTCTIME;    break;
3088                 default:                        break;
3089                 }
3090                 break;
3091             default:
3092                 break;
3093             }
3094             if (ftst) {
3095                 PL_last_lop_op = (OPCODE)ftst;
3096                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3097                         "### Saw file test %c\n", (int)ftst);
3098                 } );
3099                 FTST(ftst);
3100             }
3101             else {
3102                 /* Assume it was a minus followed by a one-letter named
3103                  * subroutine call (or a -bareword), then. */
3104                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3105                         "### '-%c' looked like a file test but was not\n",
3106                         (int) tmp);
3107                 } );
3108                 s = --PL_bufptr;
3109             }
3110         }
3111         tmp = *s++;
3112         if (*s == tmp) {
3113             s++;
3114             if (PL_expect == XOPERATOR)
3115                 TERM(POSTDEC);
3116             else
3117                 OPERATOR(PREDEC);
3118         }
3119         else if (*s == '>') {
3120             s++;
3121             s = skipspace(s);
3122             if (isIDFIRST_lazy_if(s,UTF)) {
3123                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3124                 TOKEN(ARROW);
3125             }
3126             else if (*s == '$')
3127                 OPERATOR(ARROW);
3128             else
3129                 TERM(ARROW);
3130         }
3131         if (PL_expect == XOPERATOR)
3132             Aop(OP_SUBTRACT);
3133         else {
3134             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3135                 check_uni();
3136             OPERATOR('-');              /* unary minus */
3137         }
3138
3139     case '+':
3140         tmp = *s++;
3141         if (*s == tmp) {
3142             s++;
3143             if (PL_expect == XOPERATOR)
3144                 TERM(POSTINC);
3145             else
3146                 OPERATOR(PREINC);
3147         }
3148         if (PL_expect == XOPERATOR)
3149             Aop(OP_ADD);
3150         else {
3151             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3152                 check_uni();
3153             OPERATOR('+');
3154         }
3155
3156     case '*':
3157         if (PL_expect != XOPERATOR) {
3158             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3159             PL_expect = XOPERATOR;
3160             force_ident(PL_tokenbuf, '*');
3161             if (!*PL_tokenbuf)
3162                 PREREF('*');
3163             TERM('*');
3164         }
3165         s++;
3166         if (*s == '*') {
3167             s++;
3168             PWop(OP_POW);
3169         }
3170         Mop(OP_MULTIPLY);
3171
3172     case '%':
3173         if (PL_expect == XOPERATOR) {
3174             ++s;
3175             Mop(OP_MODULO);
3176         }
3177         PL_tokenbuf[0] = '%';
3178         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3179         if (!PL_tokenbuf[1]) {
3180             PREREF('%');
3181         }
3182         PL_pending_ident = '%';
3183         TERM('%');
3184
3185     case '^':
3186         s++;
3187         BOop(OP_BIT_XOR);
3188     case '[':
3189         PL_lex_brackets++;
3190         /* FALL THROUGH */
3191     case '~':
3192     case ',':
3193         tmp = *s++;
3194         OPERATOR(tmp);
3195     case ':':
3196         if (s[1] == ':') {
3197             len = 0;
3198             goto just_a_word;
3199         }
3200         s++;
3201         switch (PL_expect) {
3202             OP *attrs;
3203         case XOPERATOR:
3204             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3205                 break;
3206             PL_bufptr = s;      /* update in case we back off */
3207             goto grabattrs;
3208         case XATTRBLOCK:
3209             PL_expect = XBLOCK;
3210             goto grabattrs;
3211         case XATTRTERM:
3212             PL_expect = XTERMBLOCK;
3213          grabattrs:
3214             s = skipspace(s);
3215             attrs = Nullop;
3216             while (isIDFIRST_lazy_if(s,UTF)) {
3217                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3218                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3219                     if (tmp < 0) tmp = -tmp;
3220                     switch (tmp) {
3221                     case KEY_or:
3222                     case KEY_and:
3223                     case KEY_err:
3224                     case KEY_for:
3225                     case KEY_unless:
3226                     case KEY_if:
3227                     case KEY_while:
3228                     case KEY_until:
3229                         goto got_attrs;
3230                     default:
3231                         break;
3232                     }
3233                 }
3234                 if (*d == '(') {
3235                     d = scan_str(d,TRUE,TRUE);
3236                     if (!d) {
3237                         /* MUST advance bufptr here to avoid bogus
3238                            "at end of line" context messages from yyerror().
3239                          */
3240                         PL_bufptr = s + len;
3241                         yyerror("Unterminated attribute parameter in attribute list");
3242                         if (attrs)
3243                             op_free(attrs);
3244                         return REPORT(0);       /* EOF indicator */
3245                     }
3246                 }
3247                 if (PL_lex_stuff) {
3248                     SV *sv = newSVpvn(s, len);
3249                     sv_catsv(sv, PL_lex_stuff);
3250                     attrs = append_elem(OP_LIST, attrs,
3251                                         newSVOP(OP_CONST, 0, sv));
3252                     SvREFCNT_dec(PL_lex_stuff);
3253                     PL_lex_stuff = Nullsv;
3254                 }
3255                 else {
3256                     if (len == 6 && strnEQ(s, "unique", len)) {
3257                         if (PL_in_my == KEY_our)
3258 #ifdef USE_ITHREADS
3259                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3260 #else
3261                             ; /* skip to avoid loading attributes.pm */
3262 #endif
3263                         else
3264                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3265                     }
3266
3267                     /* NOTE: any CV attrs applied here need to be part of
3268                        the CVf_BUILTIN_ATTRS define in cv.h! */
3269                     else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3270                         CvLVALUE_on(PL_compcv);
3271                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3272                         CvLOCKED_on(PL_compcv);
3273                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3274                         CvMETHOD_on(PL_compcv);
3275                     else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3276                         CvASSERTION_on(PL_compcv);
3277                     /* After we've set the flags, it could be argued that
3278                        we don't need to do the attributes.pm-based setting
3279                        process, and shouldn't bother appending recognized
3280                        flags.  To experiment with that, uncomment the
3281                        following "else".  (Note that's already been
3282                        uncommented.  That keeps the above-applied built-in
3283                        attributes from being intercepted (and possibly
3284                        rejected) by a package's attribute routines, but is
3285                        justified by the performance win for the common case
3286                        of applying only built-in attributes.) */
3287                     else
3288                         attrs = append_elem(OP_LIST, attrs,
3289                                             newSVOP(OP_CONST, 0,
3290                                                     newSVpvn(s, len)));
3291                 }
3292                 s = skipspace(d);
3293                 if (*s == ':' && s[1] != ':')
3294                     s = skipspace(s+1);
3295                 else if (s == d)
3296                     break;      /* require real whitespace or :'s */
3297             }
3298             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3299             if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3300                 const char q = ((*s == '\'') ? '"' : '\'');
3301                 /* If here for an expression, and parsed no attrs, back off. */
3302                 if (tmp == '=' && !attrs) {
3303                     s = PL_bufptr;
3304                     break;
3305                 }
3306                 /* MUST advance bufptr here to avoid bogus "at end of line"
3307                    context messages from yyerror().
3308                  */
3309                 PL_bufptr = s;
3310                 if (!*s)
3311                     yyerror("Unterminated attribute list");
3312                 else
3313                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3314                                       q, *s, q));
3315                 if (attrs)
3316                     op_free(attrs);
3317                 OPERATOR(':');
3318             }
3319         got_attrs:
3320             if (attrs) {
3321                 PL_nextval[PL_nexttoke].opval = attrs;
3322                 force_next(THING);
3323             }
3324             TOKEN(COLONATTR);
3325         }
3326         OPERATOR(':');
3327     case '(':
3328         s++;
3329         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3330             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3331         else
3332             PL_expect = XTERM;
3333         s = skipspace(s);
3334         TOKEN('(');
3335     case ';':
3336         CLINE;
3337         tmp = *s++;
3338         OPERATOR(tmp);
3339     case ')':
3340         tmp = *s++;
3341         s = skipspace(s);
3342         if (*s == '{')
3343             PREBLOCK(tmp);
3344         TERM(tmp);
3345     case ']':
3346         s++;
3347         if (PL_lex_brackets <= 0)
3348             yyerror("Unmatched right square bracket");
3349         else
3350             --PL_lex_brackets;
3351         if (PL_lex_state == LEX_INTERPNORMAL) {
3352             if (PL_lex_brackets == 0) {
3353                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3354                     PL_lex_state = LEX_INTERPEND;
3355             }
3356         }
3357         TERM(']');
3358     case '{':
3359       leftbracket:
3360         s++;
3361         if (PL_lex_brackets > 100) {
3362             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3363         }
3364         switch (PL_expect) {
3365         case XTERM:
3366             if (PL_lex_formbrack) {
3367                 s--;
3368                 PRETERMBLOCK(DO);
3369             }
3370             if (PL_oldoldbufptr == PL_last_lop)
3371                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3372             else
3373                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3374             OPERATOR(HASHBRACK);
3375         case XOPERATOR:
3376             while (s < PL_bufend && SPACE_OR_TAB(*s))
3377                 s++;
3378             d = s;
3379             PL_tokenbuf[0] = '\0';
3380             if (d < PL_bufend && *d == '-') {
3381                 PL_tokenbuf[0] = '-';
3382                 d++;
3383                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3384                     d++;
3385             }
3386             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3387                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3388                               FALSE, &len);
3389                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3390                     d++;
3391                 if (*d == '}') {
3392                     const char minus = (PL_tokenbuf[0] == '-');
3393                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3394                     if (minus)
3395                         force_next('-');
3396                 }
3397             }
3398             /* FALL THROUGH */
3399         case XATTRBLOCK:
3400         case XBLOCK:
3401             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3402             PL_expect = XSTATE;
3403             break;
3404         case XATTRTERM:
3405         case XTERMBLOCK:
3406             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3407             PL_expect = XSTATE;
3408             break;
3409         default: {
3410                 const char *t;
3411                 if (PL_oldoldbufptr == PL_last_lop)
3412                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3413                 else
3414                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3415                 s = skipspace(s);
3416                 if (*s == '}') {
3417                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3418                         PL_expect = XTERM;
3419                         /* This hack is to get the ${} in the message. */
3420                         PL_bufptr = s+1;
3421                         yyerror("syntax error");
3422                         break;
3423                     }
3424                     OPERATOR(HASHBRACK);
3425                 }
3426                 /* This hack serves to disambiguate a pair of curlies
3427                  * as being a block or an anon hash.  Normally, expectation
3428                  * determines that, but in cases where we're not in a
3429                  * position to expect anything in particular (like inside
3430                  * eval"") we have to resolve the ambiguity.  This code
3431                  * covers the case where the first term in the curlies is a
3432                  * quoted string.  Most other cases need to be explicitly
3433                  * disambiguated by prepending a "+" before the opening
3434                  * curly in order to force resolution as an anon hash.
3435                  *
3436                  * XXX should probably propagate the outer expectation
3437                  * into eval"" to rely less on this hack, but that could
3438                  * potentially break current behavior of eval"".
3439                  * GSAR 97-07-21
3440                  */
3441                 t = s;
3442                 if (*s == '\'' || *s == '"' || *s == '`') {
3443                     /* common case: get past first string, handling escapes */
3444                     for (t++; t < PL_bufend && *t != *s;)
3445                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3446                             t++;
3447                     t++;
3448                 }
3449                 else if (*s == 'q') {
3450                     if (++t < PL_bufend
3451                         && (!isALNUM(*t)
3452                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3453                                 && !isALNUM(*t))))
3454                     {
3455                         /* skip q//-like construct */
3456                         const char *tmps;
3457                         char open, close, term;
3458                         I32 brackets = 1;
3459
3460                         while (t < PL_bufend && isSPACE(*t))
3461                             t++;
3462                         /* check for q => */
3463                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3464                             OPERATOR(HASHBRACK);
3465                         }
3466                         term = *t;
3467                         open = term;
3468                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3469                             term = tmps[5];
3470                         close = term;
3471                         if (open == close)
3472                             for (t++; t < PL_bufend; t++) {
3473                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3474                                     t++;
3475                                 else if (*t == open)
3476                                     break;
3477                             }
3478                         else {
3479                             for (t++; t < PL_bufend; t++) {
3480                                 if (*t == '\\' && t+1 < PL_bufend)
3481                                     t++;
3482                                 else if (*t == close && --brackets <= 0)
3483                                     break;
3484                                 else if (*t == open)
3485                                     brackets++;
3486                             }
3487                         }
3488                         t++;
3489                     }
3490                     else
3491                         /* skip plain q word */
3492                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3493                              t += UTF8SKIP(t);
3494                 }
3495                 else if (isALNUM_lazy_if(t,UTF)) {
3496                     t += UTF8SKIP(t);
3497                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3498                          t += UTF8SKIP(t);
3499                 }
3500                 while (t < PL_bufend && isSPACE(*t))
3501                     t++;
3502                 /* if comma follows first term, call it an anon hash */
3503                 /* XXX it could be a comma expression with loop modifiers */
3504                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3505                                    || (*t == '=' && t[1] == '>')))
3506                     OPERATOR(HASHBRACK);
3507                 if (PL_expect == XREF)
3508                     PL_expect = XTERM;
3509                 else {
3510                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3511                     PL_expect = XSTATE;
3512                 }
3513             }
3514             break;
3515         }
3516         yylval.ival = CopLINE(PL_curcop);
3517         if (isSPACE(*s) || *s == '#')
3518             PL_copline = NOLINE;   /* invalidate current command line number */
3519         TOKEN('{');
3520     case '}':
3521       rightbracket:
3522         s++;
3523         if (PL_lex_brackets <= 0)
3524             yyerror("Unmatched right curly bracket");
3525         else
3526             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3527         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3528             PL_lex_formbrack = 0;
3529         if (PL_lex_state == LEX_INTERPNORMAL) {
3530             if (PL_lex_brackets == 0) {
3531                 if (PL_expect & XFAKEBRACK) {
3532                     PL_expect &= XENUMMASK;
3533                     PL_lex_state = LEX_INTERPEND;
3534                     PL_bufptr = s;
3535                     return yylex();     /* ignore fake brackets */
3536                 }
3537                 if (*s == '-' && s[1] == '>')
3538                     PL_lex_state = LEX_INTERPENDMAYBE;
3539                 else if (*s != '[' && *s != '{')
3540                     PL_lex_state = LEX_INTERPEND;
3541             }
3542         }
3543         if (PL_expect & XFAKEBRACK) {
3544             PL_expect &= XENUMMASK;
3545             PL_bufptr = s;
3546             return yylex();             /* ignore fake brackets */
3547         }
3548         force_next('}');
3549         TOKEN(';');
3550     case '&':
3551         s++;
3552         tmp = *s++;
3553         if (tmp == '&')
3554             AOPERATOR(ANDAND);
3555         s--;
3556         if (PL_expect == XOPERATOR) {
3557             if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
3558                 && isIDFIRST_lazy_if(s,UTF))
3559             {
3560                 CopLINE_dec(PL_curcop);
3561                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3562                 CopLINE_inc(PL_curcop);
3563             }
3564             BAop(OP_BIT_AND);
3565         }
3566
3567         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3568         if (*PL_tokenbuf) {
3569             PL_expect = XOPERATOR;
3570             force_ident(PL_tokenbuf, '&');
3571         }
3572         else
3573             PREREF('&');
3574         yylval.ival = (OPpENTERSUB_AMPER<<8);
3575         TERM('&');
3576
3577     case '|':
3578         s++;
3579         tmp = *s++;
3580         if (tmp == '|')
3581             AOPERATOR(OROR);
3582         s--;
3583         BOop(OP_BIT_OR);
3584     case '=':
3585         s++;
3586         tmp = *s++;
3587         if (tmp == '=')
3588             Eop(OP_EQ);
3589         if (tmp == '>')
3590             OPERATOR(',');
3591         if (tmp == '~')
3592             PMop(OP_MATCH);
3593         if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) && strchr("+-*/%.^&|<",tmp))
3594             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3595         s--;
3596         if (PL_expect == XSTATE && isALPHA(tmp) &&
3597                 (s == PL_linestart+1 || s[-2] == '\n') )
3598         {
3599             if (PL_in_eval && !PL_rsfp) {
3600                 d = PL_bufend;
3601                 while (s < d) {
3602                     if (*s++ == '\n') {
3603                         incline(s);
3604                         if (strnEQ(s,"=cut",4)) {
3605                             s = strchr(s,'\n');
3606                             if (s)
3607                                 s++;
3608                             else
3609                                 s = d;
3610                             incline(s);
3611                             goto retry;
3612                         }
3613                     }
3614                 }
3615                 goto retry;
3616             }
3617             s = PL_bufend;
3618             PL_doextract = TRUE;
3619             goto retry;
3620         }
3621         if (PL_lex_brackets < PL_lex_formbrack) {
3622             const char *t;
3623 #ifdef PERL_STRICT_CR
3624             for (t = s; SPACE_OR_TAB(*t); t++) ;
3625 #else
3626             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3627 #endif
3628             if (*t == '\n' || *t == '#') {
3629                 s--;
3630                 PL_expect = XBLOCK;
3631                 goto leftbracket;
3632             }
3633         }
3634         yylval.ival = 0;
3635         OPERATOR(ASSIGNOP);
3636     case '!':
3637         s++;
3638         tmp = *s++;
3639         if (tmp == '=') {
3640             /* was this !=~ where !~ was meant?
3641              * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3642
3643             if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3644                 const char *t = s+1;
3645
3646                 while (t < PL_bufend && isSPACE(*t))
3647                     ++t;
3648
3649                 if (*t == '/' || *t == '?' ||
3650                     ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
3651                     (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3652                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3653                                 "!=~ should be !~");
3654             }
3655             Eop(OP_NE);
3656         }
3657         if (tmp == '~')
3658             PMop(OP_NOT);
3659         s--;
3660         OPERATOR('!');
3661     case '<':
3662         if (PL_expect != XOPERATOR) {
3663             if (s[1] != '<' && !strchr(s,'>'))
3664                 check_uni();
3665             if (s[1] == '<')
3666                 s = scan_heredoc(s);
3667             else
3668                 s = scan_inputsymbol(s);
3669             TERM(sublex_start());
3670         }
3671         s++;
3672         tmp = *s++;
3673         if (tmp == '<')
3674             SHop(OP_LEFT_SHIFT);
3675         if (tmp == '=') {
3676             tmp = *s++;
3677             if (tmp == '>')
3678                 Eop(OP_NCMP);
3679             s--;
3680             Rop(OP_LE);
3681         }
3682         s--;
3683         Rop(OP_LT);
3684     case '>':
3685         s++;
3686         tmp = *s++;
3687         if (tmp == '>')
3688             SHop(OP_RIGHT_SHIFT);
3689         if (tmp == '=')
3690             Rop(OP_GE);
3691         s--;
3692         Rop(OP_GT);
3693
3694     case '$':
3695         CLINE;
3696
3697         if (PL_expect == XOPERATOR) {
3698             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3699                 PL_expect = XTERM;
3700                 depcom();
3701                 return REPORT(','); /* grandfather non-comma-format format */
3702             }
3703         }
3704
3705         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3706             PL_tokenbuf[0] = '@';
3707             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3708                            sizeof PL_tokenbuf - 1, FALSE);
3709             if (PL_expect == XOPERATOR)
3710                 no_op("Array length", s);
3711             if (!PL_tokenbuf[1])
3712                 PREREF(DOLSHARP);
3713             PL_expect = XOPERATOR;
3714             PL_pending_ident = '#';
3715             TOKEN(DOLSHARP);
3716         }
3717
3718         PL_tokenbuf[0] = '$';
3719         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3720                        sizeof PL_tokenbuf - 1, FALSE);
3721         if (PL_expect == XOPERATOR)
3722             no_op("Scalar", s);
3723         if (!PL_tokenbuf[1]) {
3724             if (s == PL_bufend)
3725                 yyerror("Final $ should be \\$ or $name");
3726             PREREF('$');
3727         }
3728
3729         /* This kludge not intended to be bulletproof. */
3730         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3731             yylval.opval = newSVOP(OP_CONST, 0,
3732                                    newSViv(PL_compiling.cop_arybase));
3733             yylval.opval->op_private = OPpCONST_ARYBASE;
3734             TERM(THING);
3735         }
3736
3737         d = s;
3738         tmp = (I32)*s;
3739         if (PL_lex_state == LEX_NORMAL)
3740             s = skipspace(s);
3741
3742         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3743             if (*s == '[') {
3744                 PL_tokenbuf[0] = '@';
3745                 if (ckWARN(WARN_SYNTAX)) {
3746                     char *t;
3747                     for(t = s + 1;
3748                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3749                         t++) ;
3750                     if (*t++ == ',') {
3751                         PL_bufptr = skipspace(PL_bufptr);
3752                         while (t < PL_bufend && *t != ']')
3753                             t++;
3754                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3755                                 "Multidimensional syntax %.*s not supported",
3756                                 (t - PL_bufptr) + 1, PL_bufptr);
3757                     }
3758                 }
3759             }
3760             else if (*s == '{') {
3761                 char *t;
3762                 PL_tokenbuf[0] = '%';
3763                 if (strEQ(PL_tokenbuf+1, "SIG")  && ckWARN(WARN_SYNTAX)
3764                     && (t = strchr(s, '}')) && (t = strchr(t, '=')))
3765                 {
3766                     char tmpbuf[sizeof PL_tokenbuf];
3767                     for (t++; isSPACE(*t); t++) ;
3768                     if (isIDFIRST_lazy_if(t,UTF)) {
3769                         STRLEN len;
3770                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3771                         for (; isSPACE(*t); t++) ;
3772                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3773                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3774                                 "You need to quote \"%s\"", tmpbuf);
3775                     }
3776                 }
3777             }
3778         }
3779
3780         PL_expect = XOPERATOR;
3781         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3782             const bool islop = (PL_last_lop == PL_oldoldbufptr);
3783             if (!islop || PL_last_lop_op == OP_GREPSTART)
3784                 PL_expect = XOPERATOR;
3785             else if (strchr("$@\"'`q", *s))
3786                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3787             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3788                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3789             else if (isIDFIRST_lazy_if(s,UTF)) {
3790                 char tmpbuf[sizeof PL_tokenbuf];
3791                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3792                 if ((tmp = keyword(tmpbuf, len))) {
3793                     /* binary operators exclude handle interpretations */
3794                     switch (tmp) {
3795                     case -KEY_x:
3796                     case -KEY_eq:
3797                     case -KEY_ne:
3798                     case -KEY_gt:
3799                     case -KEY_lt:
3800                     case -KEY_ge:
3801                     case -KEY_le:
3802                     case -KEY_cmp:
3803                         break;
3804                     default:
3805                         PL_expect = XTERM;      /* e.g. print $fh length() */
3806                         break;
3807                     }
3808                 }
3809                 else {
3810                     PL_expect = XTERM;          /* e.g. print $fh subr() */
3811                 }
3812             }
3813             else if (isDIGIT(*s))
3814                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3815             else if (*s == '.' && isDIGIT(s[1]))
3816                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3817             else if ((*s == '?' || *s == '-' || *s == '+')
3818                      && !isSPACE(s[1]) && s[1] != '=')
3819                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3820             else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3821                 PL_expect = XTERM;              /* e.g. print $fh /.../
3822                                                  XXX except DORDOR operator */
3823             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3824                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3825         }
3826         PL_pending_ident = '$';
3827         TOKEN('$');
3828
3829     case '@':
3830         if (PL_expect == XOPERATOR)
3831             no_op("Array", s);
3832         PL_tokenbuf[0] = '@';
3833         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3834         if (!PL_tokenbuf[1]) {
3835             PREREF('@');
3836         }
3837         if (PL_lex_state == LEX_NORMAL)
3838             s = skipspace(s);
3839         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3840             if (*s == '{')
3841                 PL_tokenbuf[0] = '%';
3842
3843             /* Warn about @ where they meant $. */
3844             if (*s == '[' || *s == '{') {
3845                 if (ckWARN(WARN_SYNTAX)) {
3846                     const char *t = s + 1;
3847                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3848                         t++;
3849                     if (*t == '}' || *t == ']') {
3850                         t++;
3851                         PL_bufptr = skipspace(PL_bufptr);
3852                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3853                             "Scalar value %.*s better written as $%.*s",
3854                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3855                     }
3856                 }
3857             }
3858         }
3859         PL_pending_ident = '@';
3860         TERM('@');
3861
3862      case '/':                  /* may be division, defined-or, or pattern */
3863         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3864             s += 2;
3865             AOPERATOR(DORDOR);
3866         }
3867      case '?':                  /* may either be conditional or pattern */
3868          if(PL_expect == XOPERATOR) {
3869              tmp = *s++;
3870              if(tmp == '?') {
3871                   OPERATOR('?');
3872              }
3873              else {
3874                  tmp = *s++;
3875                  if(tmp == '/') {
3876                      /* A // operator. */
3877                     AOPERATOR(DORDOR);
3878                  }
3879                  else {
3880                      s--;
3881                      Mop(OP_DIVIDE);
3882                  }
3883              }
3884          }
3885          else {
3886              /* Disable warning on "study /blah/" */
3887              if (PL_oldoldbufptr == PL_last_uni
3888               && (*PL_last_uni != 's' || s - PL_last_uni < 5
3889                   || memNE(PL_last_uni, "study", 5)
3890                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
3891               ))
3892                  check_uni();
3893              s = scan_pat(s,OP_MATCH);
3894              TERM(sublex_start());
3895          }
3896
3897     case '.':
3898         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3899 #ifdef PERL_STRICT_CR
3900             && s[1] == '\n'
3901 #else
3902             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3903 #endif
3904             && (s == PL_linestart || s[-1] == '\n') )
3905         {
3906             PL_lex_formbrack = 0;
3907             PL_expect = XSTATE;
3908             goto rightbracket;
3909         }
3910         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3911             tmp = *s++;
3912             if (*s == tmp) {
3913                 s++;
3914                 if (*s == tmp) {
3915                     s++;
3916                     yylval.ival = OPf_SPECIAL;
3917                 }
3918                 else
3919                     yylval.ival = 0;
3920                 OPERATOR(DOTDOT);
3921             }
3922             if (PL_expect != XOPERATOR)
3923                 check_uni();
3924             Aop(OP_CONCAT);
3925         }
3926         /* FALL THROUGH */
3927     case '0': case '1': case '2': case '3': case '4':
3928     case '5': case '6': case '7': case '8': case '9':
3929         s = scan_num(s, &yylval);
3930         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3931                     "### Saw number in '%s'\n", s);
3932         } );
3933         if (PL_expect == XOPERATOR)
3934             no_op("Number",s);
3935         TERM(THING);
3936
3937     case '\'':
3938         s = scan_str(s,FALSE,FALSE);
3939         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3940                     "### Saw string before '%s'\n", s);
3941         } );
3942         if (PL_expect == XOPERATOR) {
3943             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3944                 PL_expect = XTERM;
3945                 depcom();
3946                 return REPORT(','); /* grandfather non-comma-format format */
3947             }
3948             else
3949                 no_op("String",s);
3950         }
3951         if (!s)
3952             missingterm((char*)0);
3953         yylval.ival = OP_CONST;
3954         TERM(sublex_start());
3955
3956     case '"':
3957         s = scan_str(s,FALSE,FALSE);
3958         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3959                     "### Saw string before '%s'\n", s);
3960         } );
3961         if (PL_expect == XOPERATOR) {
3962             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3963                 PL_expect = XTERM;
3964                 depcom();
3965                 return REPORT(','); /* grandfather non-comma-format format */
3966             }
3967             else
3968                 no_op("String",s);
3969         }
3970         if (!s)
3971             missingterm((char*)0);
3972         yylval.ival = OP_CONST;
3973         /* FIXME. I think that this can be const if char *d is replaced by
3974            more localised variables.  */
3975         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3976             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3977                 yylval.ival = OP_STRINGIFY;
3978                 break;
3979             }
3980         }
3981         TERM(sublex_start());
3982
3983     case '`':
3984         s = scan_str(s,FALSE,FALSE);
3985         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3986                     "### Saw backtick string before '%s'\n", s);
3987         } );
3988         if (PL_expect == XOPERATOR)
3989             no_op("Backticks",s);
3990         if (!s)
3991             missingterm((char*)0);
3992         yylval.ival = OP_BACKTICK;
3993         set_csh();
3994         TERM(sublex_start());
3995
3996     case '\\':
3997         s++;
3998         if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
3999             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
4000                         *s, *s);
4001         if (PL_expect == XOPERATOR)
4002             no_op("Backslash",s);
4003         OPERATOR(REFGEN);
4004
4005     case 'v':
4006         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
4007             char *start = s + 2;
4008             while (isDIGIT(*start) || *start == '_')
4009                 start++;
4010             if (*start == '.' && isDIGIT(start[1])) {
4011                 s = scan_num(s, &yylval);
4012                 TERM(THING);
4013             }
4014             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
4015             else if (!isALPHA(*start) && (PL_expect == XTERM
4016                         || PL_expect == XREF || PL_expect == XSTATE
4017                         || PL_expect == XTERMORDORDOR)) {
4018                 const char c = *start;
4019                 GV *gv;
4020                 *start = '\0';
4021                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
4022                 *start = c;
4023                 if (!gv) {
4024                     s = scan_num(s, &yylval);
4025                     TERM(THING);
4026                 }
4027             }
4028         }
4029         goto keylookup;
4030     case 'x':
4031         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
4032             s++;
4033             Mop(OP_REPEAT);
4034         }
4035         goto keylookup;
4036
4037     case '_':
4038     case 'a': case 'A':
4039     case 'b': case 'B':
4040     case 'c': case 'C':
4041     case 'd': case 'D':
4042     case 'e': case 'E':
4043     case 'f': case 'F':
4044     case 'g': case 'G':
4045     case 'h': case 'H':
4046     case 'i': case 'I':
4047     case 'j': case 'J':
4048     case 'k': case 'K':
4049     case 'l': case 'L':
4050     case 'm': case 'M':
4051     case 'n': case 'N':
4052     case 'o': case 'O':
4053     case 'p': case 'P':
4054     case 'q': case 'Q':
4055     case 'r': case 'R':
4056     case 's': case 'S':
4057     case 't': case 'T':
4058     case 'u': case 'U':
4059               case 'V':
4060     case 'w': case 'W':
4061               case 'X':
4062     case 'y': case 'Y':
4063     case 'z': case 'Z':
4064
4065       keylookup: {
4066         orig_keyword = 0;
4067         gv = Nullgv;
4068         gvp = 0;
4069
4070         PL_bufptr = s;
4071         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4072
4073         /* Some keywords can be followed by any delimiter, including ':' */
4074         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
4075                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
4076                              (PL_tokenbuf[0] == 'q' &&
4077                               strchr("qwxr", PL_tokenbuf[1])))));
4078
4079         /* x::* is just a word, unless x is "CORE" */
4080         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
4081             goto just_a_word;
4082
4083         d = s;
4084         while (d < PL_bufend && isSPACE(*d))
4085                 d++;    /* no comments skipped here, or s### is misparsed */
4086
4087         /* Is this a label? */
4088         if (!tmp && PL_expect == XSTATE
4089               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4090             s = d + 1;
4091             yylval.pval = savepv(PL_tokenbuf);
4092             CLINE;
4093             TOKEN(LABEL);
4094         }
4095
4096         /* Check for keywords */
4097         tmp = keyword(PL_tokenbuf, len);
4098
4099         /* Is this a word before a => operator? */
4100         if (*d == '=' && d[1] == '>') {
4101             CLINE;
4102             yylval.opval
4103                 = (OP*)newSVOP(OP_CONST, 0,
4104                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4105             yylval.opval->op_private = OPpCONST_BARE;
4106             TERM(WORD);
4107         }
4108
4109         if (tmp < 0) {                  /* second-class keyword? */
4110             GV *ogv = Nullgv;   /* override (winner) */
4111             GV *hgv = Nullgv;   /* hidden (loser) */
4112             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4113                 CV *cv;
4114                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
4115                     (cv = GvCVu(gv)))
4116                 {
4117                     if (GvIMPORTED_CV(gv))
4118                         ogv = gv;
4119                     else if (! CvMETHOD(cv))
4120                         hgv = gv;
4121                 }
4122                 if (!ogv &&
4123                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4124                     (gv = *gvp) != (GV*)&PL_sv_undef &&
4125                     GvCVu(gv) && GvIMPORTED_CV(gv))
4126                 {
4127                     ogv = gv;
4128                 }
4129             }
4130             if (ogv) {
4131                 orig_keyword = tmp;
4132                 tmp = 0;                /* overridden by import or by GLOBAL */
4133             }
4134             else if (gv && !gvp
4135                      && -tmp==KEY_lock  /* XXX generalizable kludge */
4136                      && GvCVu(gv)
4137                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4138             {
4139                 tmp = 0;                /* any sub overrides "weak" keyword */
4140             }
4141             else if (gv && !gvp
4142                     && tmp == -KEY_err
4143                     && GvCVu(gv)
4144                     && PL_expect != XOPERATOR
4145                     && PL_expect != XTERMORDORDOR)
4146             {
4147                 /* any sub overrides the "err" keyword, except when really an
4148                  * operator is expected */
4149                 tmp = 0;
4150             }
4151             else {                      /* no override */
4152                 tmp = -tmp;
4153                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4154                     Perl_warner(aTHX_ packWARN(WARN_MISC),
4155                             "dump() better written as CORE::dump()");
4156                 }
4157                 gv = Nullgv;
4158                 gvp = 0;
4159                 if (hgv && tmp != KEY_x && tmp != KEY_CORE
4160                         && ckWARN(WARN_AMBIGUOUS))      /* never ambiguous */
4161                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4162                         "Ambiguous call resolved as CORE::%s(), %s",
4163                          GvENAME(hgv), "qualify as such or use &");
4164             }
4165         }
4166
4167       reserved_word:
4168         switch (tmp) {
4169
4170         default:                        /* not a keyword */
4171           just_a_word: {
4172                 SV *sv;
4173                 int pkgname = 0;
4174                 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4175
4176                 /* Get the rest if it looks like a package qualifier */
4177
4178                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4179                     STRLEN morelen;
4180                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4181                                   TRUE, &morelen);
4182                     if (!morelen)
4183                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4184                                 *s == '\'' ? "'" : "::");
4185                     len += morelen;
4186                     pkgname = 1;
4187                 }
4188
4189                 if (PL_expect == XOPERATOR) {
4190                     if (PL_bufptr == PL_linestart) {
4191                         CopLINE_dec(PL_curcop);
4192                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4193                         CopLINE_inc(PL_curcop);
4194                     }
4195                     else
4196                         no_op("Bareword",s);
4197                 }
4198
4199                 /* Look for a subroutine with this name in current package,
4200                    unless name is "Foo::", in which case Foo is a bearword
4201                    (and a package name). */
4202
4203                 if (len > 2 &&
4204                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4205                 {
4206                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
4207                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4208                             "Bareword \"%s\" refers to nonexistent package",
4209                              PL_tokenbuf);
4210                     len -= 2;
4211                     PL_tokenbuf[len] = '\0';
4212                     gv = Nullgv;
4213                     gvp = 0;
4214                 }
4215                 else {
4216                     len = 0;
4217                     if (!gv)
4218                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
4219                 }
4220
4221                 /* if we saw a global override before, get the right name */
4222
4223                 if (gvp) {
4224                     sv = newSVpvn("CORE::GLOBAL::",14);
4225                     sv_catpv(sv,PL_tokenbuf);
4226                 }
4227                 else {
4228                     /* If len is 0, newSVpv does strlen(), which is correct.
4229                        If len is non-zero, then it will be the true length,
4230                        and so the scalar will be created correctly.  */
4231                     sv = newSVpv(PL_tokenbuf,len);
4232                 }
4233
4234                 /* Presume this is going to be a bareword of some sort. */
4235
4236                 CLINE;
4237                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4238                 yylval.opval->op_private = OPpCONST_BARE;
4239                 /* UTF-8 package name? */
4240                 if (UTF && !IN_BYTES &&
4241                     is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
4242                     SvUTF8_on(sv);
4243
4244                 /* And if "Foo::", then that's what it certainly is. */
4245
4246                 if (len)
4247                     goto safe_bareword;
4248
4249                 /* See if it's the indirect object for a list operator. */
4250
4251                 if (PL_oldoldbufptr &&
4252                     PL_oldoldbufptr < PL_bufptr &&
4253                     (PL_oldoldbufptr == PL_last_lop
4254                      || PL_oldoldbufptr == PL_last_uni) &&
4255                     /* NO SKIPSPACE BEFORE HERE! */
4256                     (PL_expect == XREF ||
4257                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4258                 {
4259                     bool immediate_paren = *s == '(';
4260
4261                     /* (Now we can afford to cross potential line boundary.) */
4262                     s = skipspace(s);
4263
4264                     /* Two barewords in a row may indicate method call. */
4265
4266                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4267                         return REPORT(tmp);
4268
4269                     /* If not a declared subroutine, it's an indirect object. */
4270                     /* (But it's an indir obj regardless for sort.) */
4271
4272                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4273                          ((!gv || !GvCVu(gv)) &&
4274                         (PL_last_lop_op != OP_MAPSTART &&
4275                          PL_last_lop_op != OP_GREPSTART))))
4276                     {
4277                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4278                         goto bareword;
4279                     }
4280                 }
4281
4282                 PL_expect = XOPERATOR;
4283                 s = skipspace(s);
4284
4285                 /* Is this a word before a => operator? */
4286                 if (*s == '=' && s[1] == '>' && !pkgname) {
4287                     CLINE;
4288                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4289                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4290                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4291                     TERM(WORD);
4292                 }
4293
4294                 /* If followed by a paren, it's certainly a subroutine. */
4295                 if (*s == '(') {
4296                     CLINE;
4297                     if (gv && GvCVu(gv)) {
4298                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4299                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4300                             s = d + 1;
4301                             goto its_constant;
4302                         }
4303                     }
4304                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4305                     PL_expect = XOPERATOR;
4306                     force_next(WORD);
4307                     yylval.ival = 0;
4308                     TOKEN('&');
4309                 }
4310
4311                 /* If followed by var or block, call it a method (unless sub) */
4312
4313                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4314                     PL_last_lop = PL_oldbufptr;
4315                     PL_last_lop_op = OP_METHOD;
4316                     PREBLOCK(METHOD);
4317                 }
4318
4319                 /* If followed by a bareword, see if it looks like indir obj. */
4320
4321                 if (!orig_keyword
4322                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4323                         && (tmp = intuit_method(s,gv)))
4324                     return REPORT(tmp);
4325
4326                 /* Not a method, so call it a subroutine (if defined) */
4327
4328                 if (gv && GvCVu(gv)) {
4329                     CV* cv;
4330                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4331                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4332                                 "Ambiguous use of -%s resolved as -&%s()",
4333                                 PL_tokenbuf, PL_tokenbuf);
4334                     /* Check for a constant sub */
4335                     cv = GvCV(gv);
4336                     if ((sv = cv_const_sv(cv))) {
4337                   its_constant:
4338                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4339                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4340                         yylval.opval->op_private = 0;
4341                         TOKEN(WORD);
4342                     }
4343
4344                     /* Resolve to GV now. */
4345                     op_free(yylval.opval);
4346                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4347                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4348                     PL_last_lop = PL_oldbufptr;
4349                     PL_last_lop_op = OP_ENTERSUB;
4350                     /* Is there a prototype? */
4351                     if (SvPOK(cv)) {
4352                         STRLEN len;
4353                         const char *proto = SvPV_const((SV*)cv, len);
4354                         if (!len)
4355                             TERM(FUNC0SUB);
4356                         if (*proto == '$' && proto[1] == '\0')
4357                             OPERATOR(UNIOPSUB);
4358                         while (*proto == ';')
4359                             proto++;
4360                         if (*proto == '&' && *s == '{') {
4361                             sv_setpv(PL_subname, PL_curstash ?
4362                                         "__ANON__" : "__ANON__::__ANON__");
4363                             PREBLOCK(LSTOPSUB);
4364                         }
4365                     }
4366                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4367                     PL_expect = XTERM;
4368                     force_next(WORD);
4369                     TOKEN(NOAMP);
4370                 }
4371
4372                 /* Call it a bare word */
4373
4374                 if (PL_hints & HINT_STRICT_SUBS)
4375                     yylval.opval->op_private |= OPpCONST_STRICT;
4376                 else {
4377                 bareword:
4378                     if (lastchar != '-') {
4379                         if (ckWARN(WARN_RESERVED)) {
4380                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4381                             if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4382                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4383                                        PL_tokenbuf);
4384                         }
4385                     }
4386                 }
4387
4388             safe_bareword:
4389                 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
4390                     && ckWARN_d(WARN_AMBIGUOUS)) {
4391                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4392                         "Operator or semicolon missing before %c%s",
4393                         lastchar, PL_tokenbuf);
4394                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4395                         "Ambiguous use of %c resolved as operator %c",
4396                         lastchar, lastchar);
4397                 }
4398                 TOKEN(WORD);
4399             }
4400
4401         case KEY___FILE__:
4402             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4403                                         newSVpv(CopFILE(PL_curcop),0));
4404             TERM(THING);
4405
4406         case KEY___LINE__:
4407             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4408                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4409             TERM(THING);
4410
4411         case KEY___PACKAGE__:
4412             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4413                                         (PL_curstash
4414                                          ? newSVhek(HvNAME_HEK(PL_curstash))
4415                                          : &PL_sv_undef));
4416             TERM(THING);
4417
4418         case KEY___DATA__:
4419         case KEY___END__: {
4420             GV *gv;
4421             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4422                 const char *pname = "main";
4423                 if (PL_tokenbuf[2] == 'D')
4424                     pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
4425                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4426                 GvMULTI_on(gv);
4427                 if (!GvIO(gv))
4428                     GvIOp(gv) = newIO();
4429                 IoIFP(GvIOp(gv)) = PL_rsfp;
4430 #if defined(HAS_FCNTL) && defined(F_SETFD)
4431                 {
4432                     const int fd = PerlIO_fileno(PL_rsfp);
4433                     fcntl(fd,F_SETFD,fd >= 3);
4434                 }
4435 #endif
4436                 /* Mark this internal pseudo-handle as clean */
4437                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4438                 if (PL_preprocess)
4439                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4440                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4441                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4442                 else
4443                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4444 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4445                 /* if the script was opened in binmode, we need to revert
4446                  * it to text mode for compatibility; but only iff it has CRs
4447                  * XXX this is a questionable hack at best. */
4448                 if (PL_bufend-PL_bufptr > 2
4449                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4450                 {
4451                     Off_t loc = 0;
4452                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4453                         loc = PerlIO_tell(PL_rsfp);
4454                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
4455                     }
4456 #ifdef NETWARE
4457                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4458 #else
4459                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4460 #endif  /* NETWARE */
4461 #ifdef PERLIO_IS_STDIO /* really? */
4462 #  if defined(__BORLANDC__)
4463                         /* XXX see note in do_binmode() */
4464                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4465 #  endif
4466 #endif
4467                         if (loc > 0)
4468                             PerlIO_seek(PL_rsfp, loc, 0);
4469                     }
4470                 }
4471 #endif
4472 #ifdef PERLIO_LAYERS
4473                 if (!IN_BYTES) {
4474                     if (UTF)
4475                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4476                     else if (PL_encoding) {
4477                         SV *name;
4478                         dSP;
4479                         ENTER;
4480                         SAVETMPS;
4481                         PUSHMARK(sp);
4482                         EXTEND(SP, 1);
4483                         XPUSHs(PL_encoding);
4484                         PUTBACK;
4485                         call_method("name", G_SCALAR);
4486                         SPAGAIN;
4487                         name = POPs;
4488                         PUTBACK;
4489                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4490                                             Perl_form(aTHX_ ":encoding(%"SVf")",
4491                                                       name));
4492                         FREETMPS;
4493                         LEAVE;
4494                     }
4495                 }
4496 #endif
4497                 PL_rsfp = Nullfp;
4498             }
4499             goto fake_eof;
4500         }
4501
4502         case KEY_AUTOLOAD:
4503         case KEY_DESTROY:
4504         case KEY_BEGIN:
4505         case KEY_CHECK:
4506         case KEY_INIT:
4507         case KEY_END:
4508             if (PL_expect == XSTATE) {
4509                 s = PL_bufptr;
4510                 goto really_sub;
4511             }
4512             goto just_a_word;
4513
4514         case KEY_CORE:
4515             if (*s == ':' && s[1] == ':') {
4516                 s += 2;
4517                 d = s;
4518                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4519                 if (!(tmp = keyword(PL_tokenbuf, len)))
4520                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4521                 if (tmp < 0)
4522                     tmp = -tmp;
4523                 else if (tmp == KEY_require || tmp == KEY_do)
4524                     /* that's a way to remember we saw "CORE::" */
4525                     orig_keyword = tmp;
4526                 goto reserved_word;
4527             }
4528             goto just_a_word;
4529
4530         case KEY_abs:
4531             UNI(OP_ABS);
4532
4533         case KEY_alarm:
4534             UNI(OP_ALARM);
4535
4536         case KEY_accept:
4537             LOP(OP_ACCEPT,XTERM);
4538
4539         case KEY_and:
4540             OPERATOR(ANDOP);
4541
4542         case KEY_atan2:
4543             LOP(OP_ATAN2,XTERM);
4544
4545         case KEY_bind:
4546             LOP(OP_BIND,XTERM);
4547
4548         case KEY_binmode:
4549             LOP(OP_BINMODE,XTERM);
4550
4551         case KEY_bless:
4552             LOP(OP_BLESS,XTERM);
4553
4554         case KEY_chop:
4555             UNI(OP_CHOP);
4556
4557         case KEY_continue:
4558             PREBLOCK(CONTINUE);
4559
4560         case KEY_chdir:
4561             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
4562             UNI(OP_CHDIR);
4563
4564         case KEY_close:
4565             UNI(OP_CLOSE);
4566
4567         case KEY_closedir:
4568             UNI(OP_CLOSEDIR);
4569
4570         case KEY_cmp:
4571             Eop(OP_SCMP);
4572
4573         case KEY_caller:
4574             UNI(OP_CALLER);
4575
4576         case KEY_crypt:
4577 #ifdef FCRYPT
4578             if (!PL_cryptseen) {
4579                 PL_cryptseen = TRUE;
4580                 init_des();
4581             }
4582 #endif
4583             LOP(OP_CRYPT,XTERM);
4584
4585         case KEY_chmod:
4586             LOP(OP_CHMOD,XTERM);
4587
4588         case KEY_chown:
4589             LOP(OP_CHOWN,XTERM);
4590
4591         case KEY_connect:
4592             LOP(OP_CONNECT,XTERM);
4593
4594         case KEY_chr:
4595             UNI(OP_CHR);
4596
4597         case KEY_cos:
4598             UNI(OP_COS);
4599
4600         case KEY_chroot:
4601             UNI(OP_CHROOT);
4602
4603         case KEY_do:
4604             s = skipspace(s);
4605             if (*s == '{')
4606                 PRETERMBLOCK(DO);
4607             if (*s != '\'')
4608                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4609             if (orig_keyword == KEY_do) {
4610                 orig_keyword = 0;
4611                 yylval.ival = 1;
4612             }
4613             else
4614                 yylval.ival = 0;
4615             OPERATOR(DO);
4616
4617         case KEY_die:
4618             PL_hints |= HINT_BLOCK_SCOPE;
4619             LOP(OP_DIE,XTERM);
4620
4621         case KEY_defined:
4622             UNI(OP_DEFINED);
4623
4624         case KEY_delete:
4625             UNI(OP_DELETE);
4626
4627         case KEY_dbmopen:
4628             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4629             LOP(OP_DBMOPEN,XTERM);
4630
4631         case KEY_dbmclose:
4632             UNI(OP_DBMCLOSE);
4633
4634         case KEY_dump:
4635             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4636             LOOPX(OP_DUMP);
4637
4638         case KEY_else:
4639             PREBLOCK(ELSE);
4640
4641         case KEY_elsif:
4642             yylval.ival = CopLINE(PL_curcop);
4643             OPERATOR(ELSIF);
4644
4645         case KEY_eq:
4646             Eop(OP_SEQ);
4647
4648         case KEY_exists:
4649             UNI(OP_EXISTS);
4650         
4651         case KEY_exit:
4652             UNI(OP_EXIT);
4653
4654         case KEY_eval:
4655             s = skipspace(s);
4656             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4657             UNIBRACK(OP_ENTEREVAL);
4658
4659         case KEY_eof:
4660             UNI(OP_EOF);
4661
4662         case KEY_err:
4663             OPERATOR(DOROP);
4664
4665         case KEY_exp:
4666             UNI(OP_EXP);
4667
4668         case KEY_each:
4669             UNI(OP_EACH);
4670
4671         case KEY_exec:
4672             set_csh();
4673             LOP(OP_EXEC,XREF);
4674
4675         case KEY_endhostent:
4676             FUN0(OP_EHOSTENT);
4677
4678         case KEY_endnetent:
4679             FUN0(OP_ENETENT);
4680
4681         case KEY_endservent:
4682             FUN0(OP_ESERVENT);
4683
4684         case KEY_endprotoent:
4685             FUN0(OP_EPROTOENT);
4686
4687         case KEY_endpwent:
4688             FUN0(OP_EPWENT);
4689
4690         case KEY_endgrent:
4691             FUN0(OP_EGRENT);
4692
4693         case KEY_for:
4694         case KEY_foreach:
4695             yylval.ival = CopLINE(PL_curcop);
4696             s = skipspace(s);
4697             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4698                 char *p = s;
4699                 if ((PL_bufend - p) >= 3 &&
4700                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4701                     p += 2;
4702                 else if ((PL_bufend - p) >= 4 &&
4703                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4704                     p += 3;
4705                 p = skipspace(p);
4706                 if (isIDFIRST_lazy_if(p,UTF)) {
4707                     p = scan_ident(p, PL_bufend,
4708                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4709                     p = skipspace(p);
4710                 }
4711                 if (*p != '$')
4712                     Perl_croak(aTHX_ "Missing $ on loop variable");
4713             }
4714             OPERATOR(FOR);
4715
4716         case KEY_formline:
4717             LOP(OP_FORMLINE,XTERM);
4718
4719         case KEY_fork:
4720             FUN0(OP_FORK);
4721
4722         case KEY_fcntl:
4723             LOP(OP_FCNTL,XTERM);
4724
4725         case KEY_fileno:
4726             UNI(OP_FILENO);
4727
4728         case KEY_flock:
4729             LOP(OP_FLOCK,XTERM);
4730
4731         case KEY_gt:
4732             Rop(OP_SGT);
4733
4734         case KEY_ge:
4735             Rop(OP_SGE);
4736
4737         case KEY_grep:
4738             LOP(OP_GREPSTART, XREF);
4739
4740         case KEY_goto:
4741             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4742             LOOPX(OP_GOTO);
4743
4744         case KEY_gmtime:
4745             UNI(OP_GMTIME);
4746
4747         case KEY_getc:
4748             UNIDOR(OP_GETC);
4749
4750         case KEY_getppid:
4751             FUN0(OP_GETPPID);
4752
4753         case KEY_getpgrp:
4754             UNI(OP_GETPGRP);
4755
4756         case KEY_getpriority:
4757             LOP(OP_GETPRIORITY,XTERM);
4758
4759         case KEY_getprotobyname:
4760             UNI(OP_GPBYNAME);
4761
4762         case KEY_getprotobynumber:
4763             LOP(OP_GPBYNUMBER,XTERM);
4764
4765         case KEY_getprotoent:
4766             FUN0(OP_GPROTOENT);
4767
4768         case KEY_getpwent:
4769             FUN0(OP_GPWENT);
4770
4771         case KEY_getpwnam:
4772             UNI(OP_GPWNAM);
4773
4774         case KEY_getpwuid:
4775             UNI(OP_GPWUID);
4776
4777         case KEY_getpeername:
4778             UNI(OP_GETPEERNAME);
4779
4780         case KEY_gethostbyname:
4781             UNI(OP_GHBYNAME);
4782
4783         case KEY_gethostbyaddr:
4784             LOP(OP_GHBYADDR,XTERM);
4785
4786         case KEY_gethostent:
4787             FUN0(OP_GHOSTENT);
4788
4789         case KEY_getnetbyname:
4790             UNI(OP_GNBYNAME);
4791
4792         case KEY_getnetbyaddr:
4793             LOP(OP_GNBYADDR,XTERM);
4794
4795         case KEY_getnetent:
4796             FUN0(OP_GNETENT);
4797
4798         case KEY_getservbyname:
4799             LOP(OP_GSBYNAME,XTERM);
4800
4801         case KEY_getservbyport:
4802             LOP(OP_GSBYPORT,XTERM);
4803
4804         case KEY_getservent:
4805             FUN0(OP_GSERVENT);
4806
4807         case KEY_getsockname:
4808             UNI(OP_GETSOCKNAME);
4809
4810         case KEY_getsockopt:
4811             LOP(OP_GSOCKOPT,XTERM);
4812
4813         case KEY_getgrent:
4814             FUN0(OP_GGRENT);
4815
4816         case KEY_getgrnam:
4817             UNI(OP_GGRNAM);
4818
4819         case KEY_getgrgid:
4820             UNI(OP_GGRGID);
4821
4822         case KEY_getlogin:
4823             FUN0(OP_GETLOGIN);
4824
4825         case KEY_glob:
4826             set_csh();
4827             LOP(OP_GLOB,XTERM);
4828
4829         case KEY_hex:
4830             UNI(OP_HEX);
4831
4832         case KEY_if:
4833             yylval.ival = CopLINE(PL_curcop);
4834             OPERATOR(IF);
4835
4836         case KEY_index:
4837             LOP(OP_INDEX,XTERM);
4838
4839         case KEY_int:
4840             UNI(OP_INT);
4841
4842         case KEY_ioctl:
4843             LOP(OP_IOCTL,XTERM);
4844
4845         case KEY_join:
4846             LOP(OP_JOIN,XTERM);
4847
4848         case KEY_keys:
4849             UNI(OP_KEYS);
4850
4851         case KEY_kill:
4852             LOP(OP_KILL,XTERM);
4853
4854         case KEY_last:
4855             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4856             LOOPX(OP_LAST);
4857         
4858         case KEY_lc:
4859             UNI(OP_LC);
4860
4861         case KEY_lcfirst:
4862             UNI(OP_LCFIRST);
4863
4864         case KEY_local:
4865             yylval.ival = 0;
4866             OPERATOR(LOCAL);
4867
4868         case KEY_length:
4869             UNI(OP_LENGTH);
4870
4871         case KEY_lt:
4872             Rop(OP_SLT);
4873
4874         case KEY_le:
4875             Rop(OP_SLE);
4876
4877         case KEY_localtime:
4878             UNI(OP_LOCALTIME);
4879
4880         case KEY_log:
4881             UNI(OP_LOG);
4882
4883         case KEY_link:
4884             LOP(OP_LINK,XTERM);
4885
4886         case KEY_listen:
4887             LOP(OP_LISTEN,XTERM);
4888
4889         case KEY_lock:
4890             UNI(OP_LOCK);
4891
4892         case KEY_lstat:
4893             UNI(OP_LSTAT);
4894
4895         case KEY_m:
4896             s = scan_pat(s,OP_MATCH);
4897             TERM(sublex_start());
4898
4899         case KEY_map:
4900             LOP(OP_MAPSTART, XREF);
4901
4902         case KEY_mkdir:
4903             LOP(OP_MKDIR,XTERM);
4904
4905         case KEY_msgctl:
4906             LOP(OP_MSGCTL,XTERM);
4907
4908         case KEY_msgget:
4909             LOP(OP_MSGGET,XTERM);
4910
4911         case KEY_msgrcv:
4912             LOP(OP_MSGRCV,XTERM);
4913
4914         case KEY_msgsnd:
4915             LOP(OP_MSGSND,XTERM);
4916
4917         case KEY_our:
4918         case KEY_my:
4919             PL_in_my = tmp;
4920             s = skipspace(s);
4921             if (isIDFIRST_lazy_if(s,UTF)) {
4922                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4923                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4924                     goto really_sub;
4925                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4926                 if (!PL_in_my_stash) {
4927                     char tmpbuf[1024];
4928                     PL_bufptr = s;
4929                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4930                     yyerror(tmpbuf);
4931                 }
4932             }
4933             yylval.ival = 1;
4934             OPERATOR(MY);
4935
4936         case KEY_next:
4937             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4938             LOOPX(OP_NEXT);
4939
4940         case KEY_ne:
4941             Eop(OP_SNE);
4942
4943         case KEY_no:
4944             s = tokenize_use(0, s);
4945             OPERATOR(USE);
4946
4947         case KEY_not:
4948             if (*s == '(' || (s = skipspace(s), *s == '('))
4949                 FUN1(OP_NOT);
4950             else
4951                 OPERATOR(NOTOP);
4952
4953         case KEY_open:
4954             s = skipspace(s);
4955             if (isIDFIRST_lazy_if(s,UTF)) {
4956                 const char *t;
4957                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4958                 for (t=d; *t && isSPACE(*t); t++) ;
4959                 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4960                     /* [perl #16184] */
4961                     && !(t[0] == '=' && t[1] == '>')
4962                 ) {
4963                     Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4964                            "Precedence problem: open %.*s should be open(%.*s)",
4965                             d - s, s, d - s, s);
4966                 }
4967             }
4968             LOP(OP_OPEN,XTERM);
4969
4970         case KEY_or:
4971             yylval.ival = OP_OR;
4972             OPERATOR(OROP);
4973
4974         case KEY_ord:
4975             UNI(OP_ORD);
4976
4977         case KEY_oct:
4978             UNI(OP_OCT);
4979
4980         case KEY_opendir:
4981             LOP(OP_OPEN_DIR,XTERM);
4982
4983         case KEY_print:
4984             checkcomma(s,PL_tokenbuf,"filehandle");
4985             LOP(OP_PRINT,XREF);
4986
4987         case KEY_printf:
4988             checkcomma(s,PL_tokenbuf,"filehandle");
4989             LOP(OP_PRTF,XREF);
4990
4991         case KEY_prototype:
4992             UNI(OP_PROTOTYPE);
4993
4994         case KEY_push:
4995             LOP(OP_PUSH,XTERM);
4996
4997         case KEY_pop:
4998             UNIDOR(OP_POP);
4999
5000         case KEY_pos:
5001             UNIDOR(OP_POS);
5002         
5003         case KEY_pack:
5004             LOP(OP_PACK,XTERM);
5005
5006         case KEY_package:
5007             s = force_word(s,WORD,FALSE,TRUE,FALSE);
5008             OPERATOR(PACKAGE);
5009
5010         case KEY_pipe:
5011             LOP(OP_PIPE_OP,XTERM);
5012
5013         case KEY_q:
5014             s = scan_str(s,FALSE,FALSE);
5015             if (!s)
5016                 missingterm((char*)0);
5017             yylval.ival = OP_CONST;
5018             TERM(sublex_start());
5019
5020         case KEY_quotemeta:
5021             UNI(OP_QUOTEMETA);
5022
5023         case KEY_qw:
5024             s = scan_str(s,FALSE,FALSE);
5025             if (!s)
5026                 missingterm((char*)0);
5027             PL_expect = XOPERATOR;
5028             force_next(')');
5029             if (SvCUR(PL_lex_stuff)) {
5030                 OP *words = Nullop;
5031                 int warned = 0;
5032                 d = SvPV_force(PL_lex_stuff, len);
5033                 while (len) {
5034                     SV *sv;
5035                     for (; isSPACE(*d) && len; --len, ++d) ;
5036                     if (len) {
5037                         const char *b = d;
5038                         if (!warned && ckWARN(WARN_QW)) {
5039                             for (; !isSPACE(*d) && len; --len, ++d) {
5040                                 if (*d == ',') {
5041                                     Perl_warner(aTHX_ packWARN(WARN_QW),
5042                                         "Possible attempt to separate words with commas");
5043                                     ++warned;
5044                                 }
5045                                 else if (*d == '#') {
5046                                     Perl_warner(aTHX_ packWARN(WARN_QW),
5047                                         "Possible attempt to put comments in qw() list");
5048                                     ++warned;
5049                                 }
5050                             }
5051                         }
5052                         else {
5053                             for (; !isSPACE(*d) && len; --len, ++d) ;
5054                         }
5055                         sv = newSVpvn(b, d-b);
5056                         if (DO_UTF8(PL_lex_stuff))
5057                             SvUTF8_on(sv);
5058                         words = append_elem(OP_LIST, words,
5059                                             newSVOP(OP_CONST, 0, tokeq(sv)));
5060                     }
5061                 }
5062                 if (words) {
5063                     PL_nextval[PL_nexttoke].opval = words;
5064                     force_next(THING);
5065                 }
5066             }
5067             if (PL_lex_stuff) {
5068                 SvREFCNT_dec(PL_lex_stuff);
5069                 PL_lex_stuff = Nullsv;
5070             }
5071             PL_expect = XTERM;
5072             TOKEN('(');
5073
5074         case KEY_qq:
5075             s = scan_str(s,FALSE,FALSE);
5076             if (!s)
5077                 missingterm((char*)0);
5078             yylval.ival = OP_STRINGIFY;
5079             if (SvIVX(PL_lex_stuff) == '\'')
5080                 SvIV_set(PL_lex_stuff, 0);      /* qq'$foo' should intepolate */
5081             TERM(sublex_start());
5082
5083         case KEY_qr:
5084             s = scan_pat(s,OP_QR);
5085             TERM(sublex_start());
5086
5087         case KEY_qx:
5088             s = scan_str(s,FALSE,FALSE);
5089             if (!s)
5090                 missingterm((char*)0);
5091             yylval.ival = OP_BACKTICK;
5092             set_csh();
5093             TERM(sublex_start());
5094
5095         case KEY_return:
5096             OLDLOP(OP_RETURN);
5097
5098         case KEY_require:
5099             s = skipspace(s);
5100             if (isDIGIT(*s)) {
5101                 s = force_version(s, FALSE);
5102             }
5103             else if (*s != 'v' || !isDIGIT(s[1])
5104                     || (s = force_version(s, TRUE), *s == 'v'))
5105             {
5106                 *PL_tokenbuf = '\0';
5107                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5108                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
5109                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
5110                 else if (*s == '<')
5111                     yyerror("<> should be quotes");
5112             }
5113             if (orig_keyword == KEY_require) {
5114                 orig_keyword = 0;
5115                 yylval.ival = 1;
5116             }
5117             else 
5118                 yylval.ival = 0;
5119             PL_expect = XTERM;
5120             PL_bufptr = s;
5121             PL_last_uni = PL_oldbufptr;
5122             PL_last_lop_op = OP_REQUIRE;
5123             s = skipspace(s);
5124             return REPORT( (int)REQUIRE );
5125
5126         case KEY_reset:
5127             UNI(OP_RESET);
5128
5129         case KEY_redo:
5130             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5131             LOOPX(OP_REDO);
5132
5133         case KEY_rename:
5134             LOP(OP_RENAME,XTERM);
5135
5136         case KEY_rand:
5137             UNI(OP_RAND);
5138
5139         case KEY_rmdir:
5140             UNI(OP_RMDIR);
5141
5142         case KEY_rindex:
5143             LOP(OP_RINDEX,XTERM);
5144
5145         case KEY_read:
5146             LOP(OP_READ,XTERM);
5147
5148         case KEY_readdir:
5149             UNI(OP_READDIR);
5150
5151         case KEY_readline:
5152             set_csh();
5153             UNIDOR(OP_READLINE);
5154
5155         case KEY_readpipe:
5156             set_csh();
5157             UNI(OP_BACKTICK);
5158
5159         case KEY_rewinddir:
5160             UNI(OP_REWINDDIR);
5161
5162         case KEY_recv:
5163             LOP(OP_RECV,XTERM);
5164
5165         case KEY_reverse:
5166             LOP(OP_REVERSE,XTERM);
5167
5168         case KEY_readlink:
5169             UNIDOR(OP_READLINK);
5170
5171         case KEY_ref:
5172             UNI(OP_REF);
5173
5174         case KEY_s:
5175             s = scan_subst(s);
5176             if (yylval.opval)
5177                 TERM(sublex_start());
5178             else
5179                 TOKEN(1);       /* force error */
5180
5181         case KEY_chomp:
5182             UNI(OP_CHOMP);
5183         
5184         case KEY_scalar:
5185             UNI(OP_SCALAR);
5186
5187         case KEY_select:
5188             LOP(OP_SELECT,XTERM);
5189
5190         case KEY_seek:
5191             LOP(OP_SEEK,XTERM);
5192
5193         case KEY_semctl:
5194             LOP(OP_SEMCTL,XTERM);
5195
5196         case KEY_semget:
5197             LOP(OP_SEMGET,XTERM);
5198
5199         case KEY_semop:
5200             LOP(OP_SEMOP,XTERM);
5201
5202         case KEY_send:
5203             LOP(OP_SEND,XTERM);
5204
5205         case KEY_setpgrp:
5206             LOP(OP_SETPGRP,XTERM);
5207
5208         case KEY_setpriority:
5209             LOP(OP_SETPRIORITY,XTERM);
5210
5211         case KEY_sethostent:
5212             UNI(OP_SHOSTENT);
5213
5214         case KEY_setnetent:
5215             UNI(OP_SNETENT);
5216
5217         case KEY_setservent:
5218             UNI(OP_SSERVENT);
5219
5220         case KEY_setprotoent:
5221             UNI(OP_SPROTOENT);
5222
5223         case KEY_setpwent:
5224             FUN0(OP_SPWENT);
5225
5226         case KEY_setgrent:
5227             FUN0(OP_SGRENT);
5228
5229         case KEY_seekdir:
5230             LOP(OP_SEEKDIR,XTERM);
5231
5232         case KEY_setsockopt:
5233             LOP(OP_SSOCKOPT,XTERM);
5234
5235         case KEY_shift:
5236             UNIDOR(OP_SHIFT);
5237
5238         case KEY_shmctl:
5239             LOP(OP_SHMCTL,XTERM);
5240
5241         case KEY_shmget:
5242             LOP(OP_SHMGET,XTERM);
5243
5244         case KEY_shmread:
5245             LOP(OP_SHMREAD,XTERM);
5246
5247         case KEY_shmwrite:
5248             LOP(OP_SHMWRITE,XTERM);
5249
5250         case KEY_shutdown:
5251             LOP(OP_SHUTDOWN,XTERM);
5252
5253         case KEY_sin:
5254             UNI(OP_SIN);
5255
5256         case KEY_sleep:
5257             UNI(OP_SLEEP);
5258
5259         case KEY_socket:
5260             LOP(OP_SOCKET,XTERM);
5261
5262         case KEY_socketpair:
5263             LOP(OP_SOCKPAIR,XTERM);
5264
5265         case KEY_sort:
5266             checkcomma(s,PL_tokenbuf,"subroutine name");
5267             s = skipspace(s);
5268             if (*s == ';' || *s == ')')         /* probably a close */
5269                 Perl_croak(aTHX_ "sort is now a reserved word");
5270             PL_expect = XTERM;
5271             s = force_word(s,WORD,TRUE,TRUE,FALSE);
5272             LOP(OP_SORT,XREF);
5273
5274         case KEY_split:
5275             LOP(OP_SPLIT,XTERM);
5276
5277         case KEY_sprintf:
5278             LOP(OP_SPRINTF,XTERM);
5279
5280         case KEY_splice:
5281             LOP(OP_SPLICE,XTERM);
5282
5283         case KEY_sqrt:
5284             UNI(OP_SQRT);
5285
5286         case KEY_srand:
5287             UNI(OP_SRAND);
5288
5289         case KEY_stat:
5290             UNI(OP_STAT);
5291
5292         case KEY_study:
5293             UNI(OP_STUDY);
5294
5295         case KEY_substr:
5296             LOP(OP_SUBSTR,XTERM);
5297
5298         case KEY_format:
5299         case KEY_sub:
5300           really_sub:
5301             {
5302                 char tmpbuf[sizeof PL_tokenbuf];
5303                 SSize_t tboffset = 0;
5304                 expectation attrful;
5305                 bool have_name, have_proto, bad_proto;
5306                 const int key = tmp;
5307
5308                 s = skipspace(s);
5309
5310                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5311                     (*s == ':' && s[1] == ':'))
5312                 {
5313                     PL_expect = XBLOCK;
5314                     attrful = XATTRBLOCK;
5315                     /* remember buffer pos'n for later force_word */
5316                     tboffset = s - PL_oldbufptr;
5317                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5318                     if (strchr(tmpbuf, ':'))
5319                         sv_setpv(PL_subname, tmpbuf);
5320                     else {
5321                         sv_setsv(PL_subname,PL_curstname);
5322                         sv_catpvn(PL_subname,"::",2);
5323                         sv_catpvn(PL_subname,tmpbuf,len);
5324                     }
5325                     s = skipspace(d);
5326                     have_name = TRUE;
5327                 }
5328                 else {
5329                     if (key == KEY_my)
5330                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
5331                     PL_expect = XTERMBLOCK;
5332                     attrful = XATTRTERM;
5333                     sv_setpvn(PL_subname,"?",1);
5334                     have_name = FALSE;
5335                 }
5336
5337                 if (key == KEY_format) {
5338                     if (*s == '=')
5339                         PL_lex_formbrack = PL_lex_brackets + 1;
5340                     if (have_name)
5341                         (void) force_word(PL_oldbufptr + tboffset, WORD,
5342                                           FALSE, TRUE, TRUE);
5343                     OPERATOR(FORMAT);
5344                 }
5345
5346                 /* Look for a prototype */
5347                 if (*s == '(') {
5348                     char *p;
5349
5350                     s = scan_str(s,FALSE,FALSE);
5351                     if (!s)
5352                         Perl_croak(aTHX_ "Prototype not terminated");
5353                     /* strip spaces and check for bad characters */
5354                     d = SvPVX(PL_lex_stuff);
5355                     tmp = 0;
5356                     bad_proto = FALSE;
5357                     for (p = d; *p; ++p) {
5358                         if (!isSPACE(*p)) {
5359                             d[tmp++] = *p;
5360                             if (!strchr("$@%*;[]&\\", *p))
5361                                 bad_proto = TRUE;
5362                         }
5363                     }
5364                     d[tmp] = '\0';
5365                     if (bad_proto && ckWARN(WARN_SYNTAX))
5366                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5367                                     "Illegal character in prototype for %"SVf" : %s",
5368                                     PL_subname, d);
5369                     SvCUR_set(PL_lex_stuff, tmp);
5370                     have_proto = TRUE;
5371
5372                     s = skipspace(s);
5373                 }
5374                 else
5375                     have_proto = FALSE;
5376
5377                 if (*s == ':' && s[1] != ':')
5378                     PL_expect = attrful;
5379                 else if (*s != '{' && key == KEY_sub) {
5380                     if (!have_name)
5381                         Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5382                     else if (*s != ';')
5383                         Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname);
5384                 }
5385
5386                 if (have_proto) {
5387                     PL_nextval[PL_nexttoke].opval =
5388                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5389                     PL_lex_stuff = Nullsv;
5390                     force_next(THING);
5391                 }
5392                 if (!have_name) {
5393                     sv_setpv(PL_subname,
5394                         PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5395                     TOKEN(ANONSUB);
5396                 }
5397                 (void) force_word(PL_oldbufptr + tboffset, WORD,
5398                                   FALSE, TRUE, TRUE);
5399                 if (key == KEY_my)
5400                     TOKEN(MYSUB);
5401                 TOKEN(SUB);
5402             }
5403
5404         case KEY_system:
5405             set_csh();
5406             LOP(OP_SYSTEM,XREF);
5407
5408         case KEY_symlink:
5409             LOP(OP_SYMLINK,XTERM);
5410
5411         case KEY_syscall:
5412             LOP(OP_SYSCALL,XTERM);
5413
5414         case KEY_sysopen:
5415             LOP(OP_SYSOPEN,XTERM);
5416
5417         case KEY_sysseek:
5418             LOP(OP_SYSSEEK,XTERM);
5419
5420         case KEY_sysread:
5421             LOP(OP_SYSREAD,XTERM);
5422
5423         case KEY_syswrite:
5424             LOP(OP_SYSWRITE,XTERM);
5425
5426         case KEY_tr:
5427             s = scan_trans(s);
5428             TERM(sublex_start());
5429
5430         case KEY_tell:
5431             UNI(OP_TELL);
5432
5433         case KEY_telldir:
5434             UNI(OP_TELLDIR);
5435
5436         case KEY_tie:
5437             LOP(OP_TIE,XTERM);
5438
5439         case KEY_tied:
5440             UNI(OP_TIED);
5441
5442         case KEY_time:
5443             FUN0(OP_TIME);
5444
5445         case KEY_times:
5446             FUN0(OP_TMS);
5447
5448         case KEY_truncate:
5449             LOP(OP_TRUNCATE,XTERM);
5450
5451         case KEY_uc:
5452             UNI(OP_UC);
5453
5454         case KEY_ucfirst:
5455             UNI(OP_UCFIRST);
5456
5457         case KEY_untie:
5458             UNI(OP_UNTIE);
5459
5460         case KEY_until:
5461             yylval.ival = CopLINE(PL_curcop);
5462             OPERATOR(UNTIL);
5463
5464         case KEY_unless:
5465             yylval.ival = CopLINE(PL_curcop);
5466             OPERATOR(UNLESS);
5467
5468         case KEY_unlink:
5469             LOP(OP_UNLINK,XTERM);
5470
5471         case KEY_undef:
5472             UNIDOR(OP_UNDEF);
5473
5474         case KEY_unpack:
5475             LOP(OP_UNPACK,XTERM);
5476
5477         case KEY_utime:
5478             LOP(OP_UTIME,XTERM);
5479
5480         case KEY_umask:
5481             UNIDOR(OP_UMASK);
5482
5483         case KEY_unshift:
5484             LOP(OP_UNSHIFT,XTERM);
5485
5486         case KEY_use:
5487             s = tokenize_use(1, s);
5488             OPERATOR(USE);
5489
5490         case KEY_values:
5491             UNI(OP_VALUES);
5492
5493         case KEY_vec:
5494             LOP(OP_VEC,XTERM);
5495
5496         case KEY_while:
5497             yylval.ival = CopLINE(PL_curcop);
5498             OPERATOR(WHILE);
5499
5500         case KEY_warn:
5501             PL_hints |= HINT_BLOCK_SCOPE;
5502             LOP(OP_WARN,XTERM);
5503
5504         case KEY_wait:
5505             FUN0(OP_WAIT);
5506
5507         case KEY_waitpid:
5508             LOP(OP_WAITPID,XTERM);
5509
5510         case KEY_wantarray:
5511             FUN0(OP_WANTARRAY);
5512
5513         case KEY_write:
5514 #ifdef EBCDIC
5515         {
5516             char ctl_l[2];
5517             ctl_l[0] = toCTRL('L');
5518             ctl_l[1] = '\0';
5519             gv_fetchpv(ctl_l,TRUE, SVt_PV);
5520         }
5521 #else
5522             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
5523 #endif
5524             UNI(OP_ENTERWRITE);
5525
5526         case KEY_x:
5527             if (PL_expect == XOPERATOR)
5528                 Mop(OP_REPEAT);
5529             check_uni();
5530             goto just_a_word;
5531
5532         case KEY_xor:
5533             yylval.ival = OP_XOR;
5534             OPERATOR(OROP);
5535
5536         case KEY_y:
5537             s = scan_trans(s);
5538             TERM(sublex_start());
5539         }
5540     }}
5541 }
5542 #ifdef __SC__
5543 #pragma segment Main
5544 #endif
5545
5546 static int
5547 S_pending_ident(pTHX)
5548 {
5549     register char *d;
5550     register I32 tmp = 0;
5551     /* pit holds the identifier we read and pending_ident is reset */
5552     char pit = PL_pending_ident;
5553     PL_pending_ident = 0;
5554
5555     DEBUG_T({ PerlIO_printf(Perl_debug_log,
5556           "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5557
5558     /* if we're in a my(), we can't allow dynamics here.
5559        $foo'bar has already been turned into $foo::bar, so
5560        just check for colons.
5561
5562        if it's a legal name, the OP is a PADANY.
5563     */
5564     if (PL_in_my) {
5565         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
5566             if (strchr(PL_tokenbuf,':'))
5567                 yyerror(Perl_form(aTHX_ "No package name allowed for "
5568                                   "variable %s in \"our\"",
5569                                   PL_tokenbuf));
5570             tmp = allocmy(PL_tokenbuf);
5571         }
5572         else {
5573             if (strchr(PL_tokenbuf,':'))
5574                 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5575
5576             yylval.opval = newOP(OP_PADANY, 0);
5577             yylval.opval->op_targ = allocmy(PL_tokenbuf);
5578             return PRIVATEREF;
5579         }
5580     }
5581
5582     /*
5583        build the ops for accesses to a my() variable.
5584
5585        Deny my($a) or my($b) in a sort block, *if* $a or $b is
5586        then used in a comparison.  This catches most, but not
5587        all cases.  For instance, it catches
5588            sort { my($a); $a <=> $b }
5589        but not
5590            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5591        (although why you'd do that is anyone's guess).
5592     */
5593
5594     if (!strchr(PL_tokenbuf,':')) {
5595         if (!PL_in_my)
5596             tmp = pad_findmy(PL_tokenbuf);
5597         if (tmp != NOT_IN_PAD) {
5598             /* might be an "our" variable" */
5599             if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5600                 /* build ops for a bareword */
5601                 HV *  const stash = PAD_COMPNAME_OURSTASH(tmp);
5602                 HEK * const stashname = HvNAME_HEK(stash);
5603                 SV *  const sym = newSVhek(stashname);
5604                 sv_catpvn(sym, "::", 2);
5605                 sv_catpv(sym, PL_tokenbuf+1);
5606                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5607                 yylval.opval->op_private = OPpCONST_ENTERED;
5608                 gv_fetchsv(sym,
5609                     (PL_in_eval
5610                         ? (GV_ADDMULTI | GV_ADDINEVAL)
5611                         : GV_ADDMULTI
5612                     ),
5613                     ((PL_tokenbuf[0] == '$') ? SVt_PV
5614                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5615                      : SVt_PVHV));
5616                 return WORD;
5617             }
5618
5619             /* if it's a sort block and they're naming $a or $b */
5620             if (PL_last_lop_op == OP_SORT &&
5621                 PL_tokenbuf[0] == '$' &&
5622                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5623                 && !PL_tokenbuf[2])
5624             {
5625                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5626                      d < PL_bufend && *d != '\n';
5627                      d++)
5628                 {
5629                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5630                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5631                               PL_tokenbuf);
5632                     }
5633                 }
5634             }
5635
5636             yylval.opval = newOP(OP_PADANY, 0);
5637             yylval.opval->op_targ = tmp;
5638             return PRIVATEREF;
5639         }
5640     }
5641
5642     /*
5643        Whine if they've said @foo in a doublequoted string,
5644        and @foo isn't a variable we can find in the symbol
5645        table.
5646     */
5647     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5648         GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5649         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5650              && ckWARN(WARN_AMBIGUOUS))
5651         {
5652             /* Downgraded from fatal to warning 20000522 mjd */
5653             Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5654                         "Possible unintended interpolation of %s in string",
5655                          PL_tokenbuf);
5656         }
5657     }
5658
5659     /* build ops for a bareword */
5660     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5661     yylval.opval->op_private = OPpCONST_ENTERED;
5662     gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5663                ((PL_tokenbuf[0] == '$') ? SVt_PV
5664                 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5665                 : SVt_PVHV));
5666     return WORD;
5667 }
5668
5669 /*
5670  *  The following code was generated by perl_keyword.pl.
5671  */
5672
5673 I32
5674 Perl_keyword (pTHX_ const char *name, I32 len)
5675 {
5676   switch (len)
5677   {
5678     case 1: /* 5 tokens of length 1 */
5679       switch (name[0])
5680       {
5681         case 'm':
5682           {                                       /* m          */
5683             return KEY_m;
5684           }
5685
5686         case 'q':
5687           {                                       /* q          */
5688             return KEY_q;
5689           }
5690
5691         case 's':
5692           {                                       /* s          */
5693             return KEY_s;
5694           }
5695
5696         case 'x':
5697           {                                       /* x          */
5698             return -KEY_x;
5699           }
5700
5701         case 'y':
5702           {                                       /* y          */
5703             return KEY_y;
5704           }
5705
5706         default:
5707           goto unknown;
5708       }
5709
5710     case 2: /* 18 tokens of length 2 */
5711       switch (name[0])
5712       {
5713         case 'd':
5714           if (name[1] == 'o')
5715           {                                       /* do         */
5716             return KEY_do;
5717           }
5718
5719           goto unknown;
5720
5721         case 'e':
5722           if (name[1] == 'q')
5723           {                                       /* eq         */
5724             return -KEY_eq;
5725           }
5726
5727           goto unknown;
5728
5729         case 'g':
5730           switch (name[1])
5731           {
5732             case 'e':
5733               {                                   /* ge         */
5734                 return -KEY_ge;
5735               }
5736
5737             case 't':
5738               {                                   /* gt         */
5739                 return -KEY_gt;
5740               }
5741
5742             default:
5743               goto unknown;
5744           }
5745
5746         case 'i':
5747           if (name[1] == 'f')
5748           {                                       /* if         */
5749             return KEY_if;
5750           }
5751
5752           goto unknown;
5753
5754         case 'l':
5755           switch (name[1])
5756           {
5757             case 'c':
5758               {                                   /* lc         */
5759                 return -KEY_lc;
5760               }
5761
5762             case 'e':
5763               {                                   /* le         */
5764                 return -KEY_le;
5765               }
5766
5767             case 't':
5768               {                                   /* lt         */
5769                 return -KEY_lt;
5770               }
5771
5772             default:
5773               goto unknown;
5774           }
5775
5776         case 'm':
5777           if (name[1] == 'y')
5778           {                                       /* my         */
5779             return KEY_my;
5780           }
5781
5782           goto unknown;
5783
5784         case 'n':
5785           switch (name[1])
5786           {
5787             case 'e':
5788               {                                   /* ne         */
5789                 return -KEY_ne;
5790               }
5791
5792             case 'o':
5793               {                                   /* no         */
5794                 return KEY_no;
5795               }
5796
5797             default:
5798               goto unknown;
5799           }
5800
5801         case 'o':
5802           if (name[1] == 'r')
5803           {                                       /* or         */
5804             return -KEY_or;
5805           }
5806
5807           goto unknown;
5808
5809         case 'q':
5810           switch (name[1])
5811           {
5812             case 'q':
5813               {                                   /* qq         */
5814                 return KEY_qq;
5815               }
5816
5817             case 'r':
5818               {                                   /* qr         */
5819                 return KEY_qr;
5820               }
5821
5822             case 'w':
5823               {                                   /* qw         */
5824                 return KEY_qw;
5825               }
5826
5827             case 'x':
5828               {                                   /* qx         */
5829                 return KEY_qx;
5830               }
5831
5832             default:
5833               goto unknown;
5834           }
5835
5836         case 't':
5837           if (name[1] == 'r')
5838           {                                       /* tr         */
5839             return KEY_tr;
5840           }
5841
5842           goto unknown;
5843
5844         case 'u':
5845           if (name[1] == 'c')
5846           {                                       /* uc         */
5847             return -KEY_uc;
5848           }
5849
5850           goto unknown;
5851
5852         default:
5853           goto unknown;
5854       }
5855
5856     case 3: /* 28 tokens of length 3 */
5857       switch (name[0])
5858       {
5859         case 'E':
5860           if (name[1] == 'N' &&
5861               name[2] == 'D')
5862           {                                       /* END        */
5863             return KEY_END;
5864           }
5865
5866           goto unknown;
5867
5868         case 'a':
5869           switch (name[1])
5870           {
5871             case 'b':
5872               if (name[2] == 's')
5873               {                                   /* abs        */
5874                 return -KEY_abs;
5875               }
5876
5877               goto unknown;
5878
5879             case 'n':
5880               if (name[2] == 'd')
5881               {                                   /* and        */
5882                 return -KEY_and;
5883               }
5884
5885               goto unknown;
5886
5887             default:
5888               goto unknown;
5889           }
5890
5891         case 'c':
5892           switch (name[1])
5893           {
5894             case 'h':
5895               if (name[2] == 'r')
5896               {                                   /* chr        */
5897                 return -KEY_chr;
5898               }
5899
5900               goto unknown;
5901
5902             case 'm':
5903               if (name[2] == 'p')
5904               {                                   /* cmp        */
5905                 return -KEY_cmp;
5906               }
5907
5908               goto unknown;
5909
5910             case 'o':
5911               if (name[2] == 's')
5912               {                                   /* cos        */
5913                 return -KEY_cos;
5914               }
5915
5916               goto unknown;
5917
5918             default:
5919               goto unknown;
5920           }
5921
5922         case 'd':
5923           if (name[1] == 'i' &&
5924               name[2] == 'e')
5925           {                                       /* die        */
5926             return -KEY_die;
5927           }
5928
5929           goto unknown;
5930
5931         case 'e':
5932           switch (name[1])
5933           {
5934             case 'o':
5935               if (name[2] == 'f')
5936               {                                   /* eof        */
5937                 return -KEY_eof;
5938               }
5939
5940               goto unknown;
5941
5942             case 'r':
5943               if (name[2] == 'r')
5944               {                                   /* err        */
5945                 return -KEY_err;
5946               }
5947
5948               goto unknown;
5949
5950             case 'x':
5951               if (name[2] == 'p')
5952               {                                   /* exp        */
5953                 return -KEY_exp;
5954               }
5955
5956               goto unknown;
5957
5958             default:
5959               goto unknown;
5960           }
5961
5962         case 'f':
5963           if (name[1] == 'o' &&
5964               name[2] == 'r')
5965           {                                       /* for        */
5966             return KEY_for;
5967           }
5968
5969           goto unknown;
5970
5971         case 'h':
5972           if (name[1] == 'e' &&
5973               name[2] == 'x')
5974           {                                       /* hex        */
5975             return -KEY_hex;
5976           }
5977
5978           goto unknown;
5979
5980         case 'i':
5981           if (name[1] == 'n' &&
5982               name[2] == 't')
5983           {                                       /* int        */
5984             return -KEY_int;
5985           }
5986
5987           goto unknown;
5988
5989         case 'l':
5990           if (name[1] == 'o' &&
5991               name[2] == 'g')
5992           {                                       /* log        */
5993             return -KEY_log;
5994           }
5995
5996           goto unknown;
5997
5998         case 'm':
5999           if (name[1] == 'a' &&
6000               name[2] == 'p')
6001           {                                       /* map        */
6002             return KEY_map;
6003           }
6004
6005           goto unknown;
6006
6007         case 'n':
6008           if (name[1] == 'o' &&
6009               name[2] == 't')
6010           {                                       /* not        */
6011             return -KEY_not;
6012           }
6013
6014           goto unknown;
6015
6016         case 'o':
6017           switch (name[1])
6018           {
6019             case 'c':
6020               if (name[2] == 't')
6021               {                                   /* oct        */
6022                 return -KEY_oct;
6023               }
6024
6025               goto unknown;
6026
6027             case 'r':
6028               if (name[2] == 'd')
6029               {                                   /* ord        */
6030                 return -KEY_ord;
6031               }
6032
6033               goto unknown;
6034
6035             case 'u':
6036               if (name[2] == 'r')
6037               {                                   /* our        */
6038                 return KEY_our;
6039               }
6040
6041               goto unknown;
6042
6043             default:
6044               goto unknown;
6045           }
6046
6047         case 'p':
6048           if (name[1] == 'o')
6049           {
6050             switch (name[2])
6051             {
6052               case 'p':
6053                 {                                 /* pop        */
6054                   return -KEY_pop;
6055                 }
6056
6057               case 's':
6058                 {                                 /* pos        */
6059                   return KEY_pos;
6060                 }
6061
6062               default:
6063                 goto unknown;
6064             }
6065           }
6066
6067           goto unknown;
6068
6069         case 'r':
6070           if (name[1] == 'e' &&
6071               name[2] == 'f')
6072           {                                       /* ref        */
6073             return -KEY_ref;
6074           }
6075
6076           goto unknown;
6077
6078         case 's':
6079           switch (name[1])
6080           {
6081             case 'i':
6082               if (name[2] == 'n')
6083               {                                   /* sin        */
6084                 return -KEY_sin;
6085               }
6086
6087               goto unknown;
6088
6089             case 'u':
6090               if (name[2] == 'b')
6091               {                                   /* sub        */
6092                 return KEY_sub;
6093               }
6094
6095               goto unknown;
6096
6097             default:
6098               goto unknown;
6099           }
6100
6101         case 't':
6102           if (name[1] == 'i' &&
6103               name[2] == 'e')
6104           {                                       /* tie        */
6105             return KEY_tie;
6106           }
6107
6108           goto unknown;
6109
6110         case 'u':
6111           if (name[1] == 's' &&
6112               name[2] == 'e')
6113           {                                       /* use        */
6114             return KEY_use;
6115           }
6116
6117           goto unknown;
6118
6119         case 'v':
6120           if (name[1] == 'e' &&
6121               name[2] == 'c')
6122           {                                       /* vec        */
6123             return -KEY_vec;
6124           }
6125
6126           goto unknown;
6127
6128         case 'x':
6129           if (name[1] == 'o' &&
6130               name[2] == 'r')
6131           {                                       /* xor        */
6132             return -KEY_xor;
6133           }
6134
6135           goto unknown;
6136
6137         default:
6138           goto unknown;
6139       }
6140
6141     case 4: /* 40 tokens of length 4 */
6142       switch (name[0])
6143       {
6144         case 'C':
6145           if (name[1] == 'O' &&
6146               name[2] == 'R' &&
6147               name[3] == 'E')
6148           {                                       /* CORE       */
6149             return -KEY_CORE;
6150           }
6151
6152           goto unknown;
6153
6154         case 'I':
6155           if (name[1] == 'N' &&
6156               name[2] == 'I' &&
6157               name[3] == 'T')
6158           {                                       /* INIT       */
6159             return KEY_INIT;
6160           }
6161
6162           goto unknown;
6163
6164         case 'b':
6165           if (name[1] == 'i' &&
6166               name[2] == 'n' &&
6167               name[3] == 'd')
6168           {                                       /* bind       */
6169             return -KEY_bind;
6170           }
6171
6172           goto unknown;
6173
6174         case 'c':
6175           if (name[1] == 'h' &&
6176               name[2] == 'o' &&
6177               name[3] == 'p')
6178           {                                       /* chop       */
6179             return -KEY_chop;
6180           }
6181
6182           goto unknown;
6183
6184         case 'd':
6185           if (name[1] == 'u' &&
6186               name[2] == 'm' &&
6187               name[3] == 'p')
6188           {                                       /* dump       */
6189             return -KEY_dump;
6190           }
6191
6192           goto unknown;
6193
6194         case 'e':
6195           switch (name[1])
6196           {
6197             case 'a':
6198               if (name[2] == 'c' &&
6199                   name[3] == 'h')
6200               {                                   /* each       */
6201                 return -KEY_each;
6202               }
6203
6204               goto unknown;
6205
6206             case 'l':
6207               if (name[2] == 's' &&
6208                   name[3] == 'e')
6209               {                                   /* else       */
6210                 return KEY_else;
6211               }
6212
6213               goto unknown;
6214
6215             case 'v':
6216               if (name[2] == 'a' &&
6217                   name[3] == 'l')
6218               {                                   /* eval       */
6219                 return KEY_eval;
6220               }
6221
6222               goto unknown;
6223
6224             case 'x':
6225               switch (name[2])
6226               {
6227                 case 'e':
6228                   if (name[3] == 'c')
6229                   {                               /* exec       */
6230                     return -KEY_exec;
6231                   }
6232
6233                   goto unknown;
6234
6235                 case 'i':
6236                   if (name[3] == 't')
6237                   {                               /* exit       */
6238                     return -KEY_exit;
6239                   }
6240
6241                   goto unknown;
6242
6243                 default:
6244                   goto unknown;
6245               }
6246
6247             default:
6248               goto unknown;
6249           }
6250
6251         case 'f':
6252           if (name[1] == 'o' &&
6253               name[2] == 'r' &&
6254               name[3] == 'k')
6255           {                                       /* fork       */
6256             return -KEY_fork;
6257           }
6258
6259           goto unknown;
6260
6261         case 'g':
6262           switch (name[1])
6263           {
6264             case 'e':
6265               if (name[2] == 't' &&
6266                   name[3] == 'c')
6267               {                                   /* getc       */
6268                 return -KEY_getc;
6269               }
6270
6271               goto unknown;
6272
6273             case 'l':
6274               if (name[2] == 'o' &&
6275                   name[3] == 'b')
6276               {                                   /* glob       */
6277                 return KEY_glob;
6278               }
6279
6280               goto unknown;
6281
6282             case 'o':
6283               if (name[2] == 't' &&
6284                   name[3] == 'o')
6285               {                                   /* goto       */
6286                 return KEY_goto;
6287               }
6288
6289               goto unknown;
6290
6291             case 'r':
6292               if (name[2] == 'e' &&
6293                   name[3] == 'p')
6294               {                                   /* grep       */
6295                 return KEY_grep;
6296               }
6297
6298               goto unknown;
6299
6300             default:
6301               goto unknown;
6302           }
6303
6304         case 'j':
6305           if (name[1] == 'o' &&
6306               name[2] == 'i' &&
6307               name[3] == 'n')
6308           {                                       /* join       */
6309             return -KEY_join;
6310           }
6311
6312           goto unknown;
6313
6314         case 'k':
6315           switch (name[1])
6316           {
6317             case 'e':
6318               if (name[2] == 'y' &&
6319                   name[3] == 's')
6320               {                                   /* keys       */
6321                 return -KEY_keys;
6322               }
6323
6324               goto unknown;
6325
6326             case 'i':
6327               if (name[2] == 'l' &&
6328                   name[3] == 'l')
6329               {                                   /* kill       */
6330                 return -KEY_kill;
6331               }
6332
6333               goto unknown;
6334
6335             default:
6336               goto unknown;
6337           }
6338
6339         case 'l':
6340           switch (name[1])
6341           {
6342             case 'a':
6343               if (name[2] == 's' &&
6344                   name[3] == 't')
6345               {                                   /* last       */
6346                 return KEY_last;
6347               }
6348
6349               goto unknown;
6350
6351             case 'i':
6352               if (name[2] == 'n' &&
6353                   name[3] == 'k')
6354               {                                   /* link       */
6355                 return -KEY_link;
6356               }
6357
6358               goto unknown;
6359
6360             case 'o':
6361               if (name[2] == 'c' &&
6362                   name[3] == 'k')
6363               {                                   /* lock       */
6364                 return -KEY_lock;
6365               }
6366
6367               goto unknown;
6368
6369             default:
6370               goto unknown;
6371           }
6372
6373         case 'n':
6374           if (name[1] == 'e' &&
6375               name[2] == 'x' &&
6376               name[3] == 't')
6377           {                                       /* next       */
6378             return KEY_next;
6379           }
6380
6381           goto unknown;
6382
6383         case 'o':
6384           if (name[1] == 'p' &&
6385               name[2] == 'e' &&
6386               name[3] == 'n')
6387           {                                       /* open       */
6388             return -KEY_open;
6389           }
6390
6391           goto unknown;
6392
6393         case 'p':
6394           switch (name[1])
6395           {
6396             case 'a':
6397               if (name[2] == 'c' &&
6398                   name[3] == 'k')
6399               {                                   /* pack       */
6400                 return -KEY_pack;
6401               }
6402
6403               goto unknown;
6404
6405             case 'i':
6406               if (name[2] == 'p' &&
6407                   name[3] == 'e')
6408               {                                   /* pipe       */
6409                 return -KEY_pipe;
6410               }
6411
6412               goto unknown;
6413
6414             case 'u':
6415               if (name[2] == 's' &&
6416                   name[3] == 'h')
6417               {                                   /* push       */
6418                 return -KEY_push;
6419               }
6420
6421               goto unknown;
6422
6423             default:
6424               goto unknown;
6425           }
6426
6427         case 'r':
6428           switch (name[1])
6429           {
6430             case 'a':
6431               if (name[2] == 'n' &&
6432                   name[3] == 'd')
6433               {                                   /* rand       */
6434                 return -KEY_rand;
6435               }
6436
6437               goto unknown;
6438
6439             case 'e':
6440               switch (name[2])
6441               {
6442                 case 'a':
6443                   if (name[3] == 'd')
6444                   {                               /* read       */
6445                     return -KEY_read;
6446                   }
6447
6448                   goto unknown;
6449
6450                 case 'c':
6451                   if (name[3] == 'v')
6452                   {                               /* recv       */
6453                     return -KEY_recv;
6454                   }
6455
6456                   goto unknown;
6457
6458                 case 'd':
6459                   if (name[3] == 'o')
6460                   {                               /* redo       */
6461                     return KEY_redo;
6462                   }
6463
6464                   goto unknown;
6465
6466                 default:
6467                   goto unknown;
6468               }
6469
6470             default:
6471               goto unknown;
6472           }
6473
6474         case 's':
6475           switch (name[1])
6476           {
6477             case 'e':
6478               switch (name[2])
6479               {
6480                 case 'e':
6481                   if (name[3] == 'k')
6482                   {                               /* seek       */
6483                     return -KEY_seek;
6484                   }
6485
6486                   goto unknown;
6487
6488                 case 'n':
6489                   if (name[3] == 'd')
6490                   {                               /* send       */
6491                     return -KEY_send;
6492                   }
6493
6494                   goto unknown;
6495
6496                 default:
6497                   goto unknown;
6498               }
6499
6500             case 'o':
6501               if (name[2] == 'r' &&
6502                   name[3] == 't')
6503               {                                   /* sort       */
6504                 return KEY_sort;
6505               }
6506
6507               goto unknown;
6508
6509             case 'q':
6510               if (name[2] == 'r' &&
6511                   name[3] == 't')
6512               {                                   /* sqrt       */
6513                 return -KEY_sqrt;
6514               }
6515
6516               goto unknown;
6517
6518             case 't':
6519               if (name[2] == 'a' &&
6520                   name[3] == 't')
6521               {                                   /* stat       */
6522                 return -KEY_stat;
6523               }
6524
6525               goto unknown;
6526
6527             default:
6528               goto unknown;
6529           }
6530
6531         case 't':
6532           switch (name[1])
6533           {
6534             case 'e':
6535               if (name[2] == 'l' &&
6536                   name[3] == 'l')
6537               {                                   /* tell       */
6538                 return -KEY_tell;
6539               }
6540
6541               goto unknown;
6542
6543             case 'i':
6544               switch (name[2])
6545               {
6546                 case 'e':
6547                   if (name[3] == 'd')
6548                   {                               /* tied       */
6549                     return KEY_tied;
6550                   }
6551
6552                   goto unknown;
6553
6554                 case 'm':
6555                   if (name[3] == 'e')
6556                   {                               /* time       */
6557                     return -KEY_time;
6558                   }
6559
6560                   goto unknown;
6561
6562                 default:
6563                   goto unknown;
6564               }
6565
6566             default:
6567               goto unknown;
6568           }
6569
6570         case 'w':
6571           if (name[1] == 'a')
6572           {
6573             switch (name[2])
6574             {
6575               case 'i':
6576                 if (name[3] == 't')
6577                 {                                 /* wait       */
6578                   return -KEY_wait;
6579                 }
6580
6581                 goto unknown;
6582
6583               case 'r':
6584                 if (name[3] == 'n')
6585                 {                                 /* warn       */
6586                   return -KEY_warn;
6587                 }
6588
6589                 goto unknown;
6590
6591               default:
6592                 goto unknown;
6593             }
6594           }
6595
6596           goto unknown;
6597
6598         default:
6599           goto unknown;
6600       }
6601
6602     case 5: /* 36 tokens of length 5 */
6603       switch (name[0])
6604       {
6605         case 'B':
6606           if (name[1] == 'E' &&
6607               name[2] == 'G' &&
6608               name[3] == 'I' &&
6609               name[4] == 'N')
6610           {                                       /* BEGIN      */
6611             return KEY_BEGIN;
6612           }
6613
6614           goto unknown;
6615
6616         case 'C':
6617           if (name[1] == 'H' &&
6618               name[2] == 'E' &&
6619               name[3] == 'C' &&
6620               name[4] == 'K')
6621           {                                       /* CHECK      */
6622             return KEY_CHECK;
6623           }
6624
6625           goto unknown;
6626
6627         case 'a':
6628           switch (name[1])
6629           {
6630             case 'l':
6631               if (name[2] == 'a' &&
6632                   name[3] == 'r' &&
6633                   name[4] == 'm')
6634               {                                   /* alarm      */
6635                 return -KEY_alarm;
6636               }
6637
6638               goto unknown;
6639
6640             case 't':
6641               if (name[2] == 'a' &&
6642                   name[3] == 'n' &&
6643                   name[4] == '2')
6644               {                                   /* atan2      */
6645                 return -KEY_atan2;
6646               }
6647
6648               goto unknown;
6649
6650             default:
6651               goto unknown;
6652           }
6653
6654         case 'b':
6655           if (name[1] == 'l' &&
6656               name[2] == 'e' &&
6657               name[3] == 's' &&
6658               name[4] == 's')
6659           {                                       /* bless      */
6660             return -KEY_bless;
6661           }
6662
6663           goto unknown;
6664
6665         case 'c':
6666           switch (name[1])
6667           {
6668             case 'h':
6669               switch (name[2])
6670               {
6671                 case 'd':
6672                   if (name[3] == 'i' &&
6673                       name[4] == 'r')
6674                   {                               /* chdir      */
6675                     return -KEY_chdir;
6676                   }
6677
6678                   goto unknown;
6679
6680                 case 'm':
6681                   if (name[3] == 'o' &&
6682                       name[4] == 'd')
6683                   {                               /* chmod      */
6684                     return -KEY_chmod;
6685                   }
6686
6687                   goto unknown;
6688
6689                 case 'o':
6690                   switch (name[3])
6691                   {
6692                     case 'm':
6693                       if (name[4] == 'p')
6694                       {                           /* chomp      */
6695                         return -KEY_chomp;
6696                       }
6697
6698                       goto unknown;
6699
6700                     case 'w':
6701                       if (name[4] == 'n')
6702                       {                           /* chown      */
6703                         return -KEY_chown;
6704                       }
6705
6706                       goto unknown;
6707
6708                     default:
6709                       goto unknown;
6710                   }
6711
6712                 default:
6713                   goto unknown;
6714               }
6715
6716             case 'l':
6717               if (name[2] == 'o' &&
6718                   name[3] == 's' &&
6719                   name[4] == 'e')
6720               {                                   /* close      */
6721                 return -KEY_close;
6722               }
6723
6724               goto unknown;
6725
6726             case 'r':
6727               if (name[2] == 'y' &&
6728                   name[3] == 'p' &&
6729                   name[4] == 't')
6730               {                                   /* crypt      */
6731                 return -KEY_crypt;
6732               }
6733
6734               goto unknown;
6735
6736             default:
6737               goto unknown;
6738           }
6739
6740         case 'e':
6741           if (name[1] == 'l' &&
6742               name[2] == 's' &&
6743               name[3] == 'i' &&
6744               name[4] == 'f')
6745           {                                       /* elsif      */
6746             return KEY_elsif;
6747           }
6748
6749           goto unknown;
6750
6751         case 'f':
6752           switch (name[1])
6753           {
6754             case 'c':
6755               if (name[2] == 'n' &&
6756                   name[3] == 't' &&
6757                   name[4] == 'l')
6758               {                                   /* fcntl      */
6759                 return -KEY_fcntl;
6760               }
6761
6762               goto unknown;
6763
6764             case 'l':
6765               if (name[2] == 'o' &&
6766                   name[3] == 'c' &&
6767                   name[4] == 'k')
6768               {                                   /* flock      */
6769                 return -KEY_flock;
6770               }
6771
6772               goto unknown;
6773
6774             default:
6775               goto unknown;
6776           }
6777
6778         case 'i':
6779           switch (name[1])
6780           {
6781             case 'n':
6782               if (name[2] == 'd' &&
6783                   name[3] == 'e' &&
6784                   name[4] == 'x')
6785               {                                   /* index      */
6786                 return -KEY_index;
6787               }
6788
6789               goto unknown;
6790
6791             case 'o':
6792               if (name[2] == 'c' &&
6793                   name[3] == 't' &&
6794                   name[4] == 'l')
6795               {                                   /* ioctl      */
6796                 return -KEY_ioctl;
6797               }
6798
6799               goto unknown;
6800
6801             default:
6802               goto unknown;
6803           }
6804
6805         case 'l':
6806           switch (name[1])
6807           {
6808             case 'o':
6809               if (name[2] == 'c' &&
6810                   name[3] == 'a' &&
6811                   name[4] == 'l')
6812               {                                   /* local      */
6813                 return KEY_local;
6814               }
6815
6816               goto unknown;
6817
6818             case 's':
6819               if (name[2] == 't' &&
6820                   name[3] == 'a' &&
6821                   name[4] == 't')
6822               {                                   /* lstat      */
6823                 return -KEY_lstat;
6824               }
6825
6826               goto unknown;
6827
6828             default:
6829               goto unknown;
6830           }
6831
6832         case 'm':
6833           if (name[1] == 'k' &&
6834               name[2] == 'd' &&
6835               name[3] == 'i' &&
6836               name[4] == 'r')
6837           {                                       /* mkdir      */
6838             return -KEY_mkdir;
6839           }
6840
6841           goto unknown;
6842
6843         case 'p':
6844           if (name[1] == 'r' &&
6845               name[2] == 'i' &&
6846               name[3] == 'n' &&
6847               name[4] == 't')
6848           {                                       /* print      */
6849             return KEY_print;
6850           }
6851
6852           goto unknown;
6853
6854         case 'r':
6855           switch (name[1])
6856           {
6857             case 'e':
6858               if (name[2] == 's' &&
6859                   name[3] == 'e' &&
6860                   name[4] == 't')
6861               {                                   /* reset      */
6862                 return -KEY_reset;
6863               }
6864
6865               goto unknown;
6866
6867             case 'm':
6868               if (name[2] == 'd' &&
6869                   name[3] == 'i' &&
6870                   name[4] == 'r')
6871               {                                   /* rmdir      */
6872                 return -KEY_rmdir;
6873               }
6874
6875               goto unknown;
6876
6877             default:
6878               goto unknown;
6879           }
6880
6881         case 's':
6882           switch (name[1])
6883           {
6884             case 'e':
6885               if (name[2] == 'm' &&
6886                   name[3] == 'o' &&
6887                   name[4] == 'p')
6888               {                                   /* semop      */
6889                 return -KEY_semop;
6890               }
6891
6892               goto unknown;
6893
6894             case 'h':
6895               if (name[2] == 'i' &&
6896                   name[3] == 'f' &&
6897                   name[4] == 't')
6898               {                                   /* shift      */
6899                 return -KEY_shift;
6900               }
6901
6902               goto unknown;
6903
6904             case 'l':
6905               if (name[2] == 'e' &&
6906                   name[3] == 'e' &&
6907                   name[4] == 'p')
6908               {                                   /* sleep      */
6909                 return -KEY_sleep;
6910               }
6911
6912               goto unknown;
6913
6914             case 'p':
6915               if (name[2] == 'l' &&
6916                   name[3] == 'i' &&
6917                   name[4] == 't')
6918               {                                   /* split      */
6919                 return KEY_split;
6920               }
6921
6922               goto unknown;
6923
6924             case 'r':
6925               if (name[2] == 'a' &&
6926                   name[3] == 'n' &&
6927                   name[4] == 'd')
6928               {                                   /* srand      */
6929                 return -KEY_srand;
6930               }
6931
6932               goto unknown;
6933
6934             case 't':
6935               if (name[2] == 'u' &&
6936                   name[3] == 'd' &&
6937                   name[4] == 'y')
6938               {                                   /* study      */
6939                 return KEY_study;
6940               }
6941
6942               goto unknown;
6943
6944             default:
6945               goto unknown;
6946           }
6947
6948         case 't':
6949           if (name[1] == 'i' &&
6950               name[2] == 'm' &&
6951               name[3] == 'e' &&
6952               name[4] == 's')
6953           {                                       /* times      */
6954             return -KEY_times;
6955           }
6956
6957           goto unknown;
6958
6959         case 'u':
6960           switch (name[1])
6961           {
6962             case 'm':
6963               if (name[2] == 'a' &&
6964                   name[3] == 's' &&
6965                   name[4] == 'k')
6966               {                                   /* umask      */
6967                 return -KEY_umask;
6968               }
6969
6970               goto unknown;
6971
6972             case 'n':
6973               switch (name[2])
6974               {
6975                 case 'd':
6976                   if (name[3] == 'e' &&
6977                       name[4] == 'f')
6978                   {                               /* undef      */
6979                     return KEY_undef;
6980                   }
6981
6982                   goto unknown;
6983
6984                 case 't':
6985                   if (name[3] == 'i')
6986                   {
6987                     switch (name[4])
6988                     {
6989                       case 'e':
6990                         {                         /* untie      */
6991                           return KEY_untie;
6992                         }
6993
6994                       case 'l':
6995                         {                         /* until      */
6996                           return KEY_until;
6997                         }
6998
6999                       default:
7000                         goto unknown;
7001                     }
7002                   }
7003
7004                   goto unknown;
7005
7006                 default:
7007                   goto unknown;
7008               }
7009
7010             case 't':
7011               if (name[2] == 'i' &&
7012                   name[3] == 'm' &&
7013                   name[4] == 'e')
7014               {                                   /* utime      */
7015                 return -KEY_utime;
7016               }
7017
7018               goto unknown;
7019
7020             default:
7021               goto unknown;
7022           }
7023
7024         case 'w':
7025           switch (name[1])
7026           {
7027             case 'h':
7028               if (name[2] == 'i' &&
7029                   name[3] == 'l' &&
7030                   name[4] == 'e')
7031               {                                   /* while      */
7032                 return KEY_while;
7033               }
7034
7035               goto unknown;
7036
7037             case 'r':
7038               if (name[2] == 'i' &&
7039                   name[3] == 't' &&
7040                   name[4] == 'e')
7041               {                                   /* write      */
7042                 return -KEY_write;
7043               }
7044
7045               goto unknown;
7046
7047             default:
7048               goto unknown;
7049           }
7050
7051         default:
7052           goto unknown;
7053       }
7054
7055     case 6: /* 33 tokens of length 6 */
7056       switch (name[0])
7057       {
7058         case 'a':
7059           if (name[1] == 'c' &&
7060               name[2] == 'c' &&
7061               name[3] == 'e' &&
7062               name[4] == 'p' &&
7063               name[5] == 't')
7064           {                                       /* accept     */
7065             return -KEY_accept;
7066           }
7067
7068           goto unknown;
7069
7070         case 'c':
7071           switch (name[1])
7072           {
7073             case 'a':
7074               if (name[2] == 'l' &&
7075                   name[3] == 'l' &&
7076                   name[4] == 'e' &&
7077                   name[5] == 'r')
7078               {                                   /* caller     */
7079                 return -KEY_caller;
7080               }
7081
7082               goto unknown;
7083
7084             case 'h':
7085               if (name[2] == 'r' &&
7086                   name[3] == 'o' &&
7087                   name[4] == 'o' &&
7088                   name[5] == 't')
7089               {                                   /* chroot     */
7090                 return -KEY_chroot;
7091               }
7092
7093               goto unknown;
7094
7095             default:
7096               goto unknown;
7097           }
7098
7099         case 'd':
7100           if (name[1] == 'e' &&
7101               name[2] == 'l' &&
7102               name[3] == 'e' &&
7103               name[4] == 't' &&
7104               name[5] == 'e')
7105           {                                       /* delete     */
7106             return KEY_delete;
7107           }
7108
7109           goto unknown;
7110
7111         case 'e':
7112           switch (name[1])
7113           {
7114             case 'l':
7115               if (name[2] == 's' &&
7116                   name[3] == 'e' &&
7117                   name[4] == 'i' &&
7118                   name[5] == 'f')
7119               {                                   /* elseif     */
7120                 if(ckWARN_d(WARN_SYNTAX))
7121                   Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
7122               }
7123
7124               goto unknown;
7125
7126             case 'x':
7127               if (name[2] == 'i' &&
7128                   name[3] == 's' &&
7129                   name[4] == 't' &&
7130                   name[5] == 's')
7131               {                                   /* exists     */
7132                 return KEY_exists;
7133               }
7134
7135               goto unknown;
7136
7137             default:
7138               goto unknown;
7139           }
7140
7141         case 'f':
7142           switch (name[1])
7143           {
7144             case 'i':
7145               if (name[2] == 'l' &&
7146                   name[3] == 'e' &&
7147                   name[4] == 'n' &&
7148                   name[5] == 'o')
7149               {                                   /* fileno     */
7150                 return -KEY_fileno;
7151               }
7152
7153               goto unknown;
7154
7155             case 'o':
7156               if (name[2] == 'r' &&
7157                   name[3] == 'm' &&
7158                   name[4] == 'a' &&
7159                   name[5] == 't')
7160               {                                   /* format     */
7161                 return KEY_format;
7162               }
7163
7164               goto unknown;
7165
7166             default:
7167               goto unknown;
7168           }
7169
7170         case 'g':
7171           if (name[1] == 'm' &&
7172               name[2] == 't' &&
7173               name[3] == 'i' &&
7174               name[4] == 'm' &&
7175               name[5] == 'e')
7176           {                                       /* gmtime     */
7177             return -KEY_gmtime;
7178           }
7179
7180           goto unknown;
7181
7182         case 'l':
7183           switch (name[1])
7184           {
7185             case 'e':
7186               if (name[2] == 'n' &&
7187                   name[3] == 'g' &&
7188                   name[4] == 't' &&
7189                   name[5] == 'h')
7190               {                                   /* length     */
7191                 return -KEY_length;
7192               }
7193
7194               goto unknown;
7195
7196             case 'i':
7197               if (name[2] == 's' &&
7198                   name[3] == 't' &&
7199                   name[4] == 'e' &&
7200                   name[5] == 'n')
7201               {                                   /* listen     */
7202                 return -KEY_listen;
7203               }
7204
7205               goto unknown;
7206
7207             default:
7208               goto unknown;
7209           }
7210
7211         case 'm':
7212           if (name[1] == 's' &&
7213               name[2] == 'g')
7214           {
7215             switch (name[3])
7216             {
7217               case 'c':
7218                 if (name[4] == 't' &&
7219                     name[5] == 'l')
7220                 {                                 /* msgctl     */
7221                   return -KEY_msgctl;
7222                 }
7223
7224                 goto unknown;
7225
7226               case 'g':
7227                 if (name[4] == 'e' &&
7228                     name[5] == 't')
7229                 {                                 /* msgget     */
7230                   return -KEY_msgget;
7231                 }
7232
7233                 goto unknown;
7234
7235               case 'r':
7236                 if (name[4] == 'c' &&
7237                     name[5] == 'v')
7238                 {                                 /* msgrcv     */
7239                   return -KEY_msgrcv;
7240                 }
7241
7242                 goto unknown;
7243
7244               case 's':
7245                 if (name[4] == 'n' &&
7246                     name[5] == 'd')
7247                 {                                 /* msgsnd     */
7248                   return -KEY_msgsnd;
7249                 }
7250
7251                 goto unknown;
7252
7253               default:
7254                 goto unknown;
7255             }
7256           }
7257
7258           goto unknown;
7259
7260         case 'p':
7261           if (name[1] == 'r' &&
7262               name[2] == 'i' &&
7263               name[3] == 'n' &&
7264               name[4] == 't' &&
7265               name[5] == 'f')
7266           {                                       /* printf     */
7267             return KEY_printf;
7268           }
7269
7270           goto unknown;
7271
7272         case 'r':
7273           switch (name[1])
7274           {
7275             case 'e':
7276               switch (name[2])
7277               {
7278                 case 'n':
7279                   if (name[3] == 'a' &&
7280                       name[4] == 'm' &&
7281                       name[5] == 'e')
7282                   {                               /* rename     */
7283                     return -KEY_rename;
7284                   }
7285
7286                   goto unknown;
7287
7288                 case 't':
7289                   if (name[3] == 'u' &&
7290                       name[4] == 'r' &&
7291                       name[5] == 'n')
7292                   {                               /* return     */
7293                     return KEY_return;
7294                   }
7295
7296                   goto unknown;
7297
7298                 default:
7299                   goto unknown;
7300               }
7301
7302             case 'i':
7303               if (name[2] == 'n' &&
7304                   name[3] == 'd' &&
7305                   name[4] == 'e' &&
7306                   name[5] == 'x')
7307               {                                   /* rindex     */
7308                 return -KEY_rindex;
7309               }
7310
7311               goto unknown;
7312
7313             default:
7314               goto unknown;
7315           }
7316
7317         case 's':
7318           switch (name[1])
7319           {
7320             case 'c':
7321               if (name[2] == 'a' &&
7322                   name[3] == 'l' &&
7323                   name[4] == 'a' &&
7324                   name[5] == 'r')
7325               {                                   /* scalar     */
7326                 return KEY_scalar;
7327               }
7328
7329               goto unknown;
7330
7331             case 'e':
7332               switch (name[2])
7333               {
7334                 case 'l':
7335                   if (name[3] == 'e' &&
7336                       name[4] == 'c' &&
7337                       name[5] == 't')
7338                   {                               /* select     */
7339                     return -KEY_select;
7340                   }
7341
7342                   goto unknown;
7343
7344                 case 'm':
7345                   switch (name[3])
7346                   {
7347                     case 'c':
7348                       if (name[4] == 't' &&
7349                           name[5] == 'l')
7350                       {                           /* semctl     */
7351                         return -KEY_semctl;
7352                       }
7353
7354                       goto unknown;
7355
7356                     case 'g':
7357                       if (name[4] == 'e' &&
7358                           name[5] == 't')
7359                       {                           /* semget     */
7360                         return -KEY_semget;
7361                       }
7362
7363                       goto unknown;
7364
7365                     default:
7366                       goto unknown;
7367                   }
7368
7369                 default:
7370                   goto unknown;
7371               }
7372
7373             case 'h':
7374               if (name[2] == 'm')
7375               {
7376                 switch (name[3])
7377                 {
7378                   case 'c':
7379                     if (name[4] == 't' &&
7380                         name[5] == 'l')
7381                     {                             /* shmctl     */
7382                       return -KEY_shmctl;
7383                     }
7384
7385                     goto unknown;
7386
7387                   case 'g':
7388                     if (name[4] == 'e' &&
7389                         name[5] == 't')
7390                     {                             /* shmget     */
7391                       return -KEY_shmget;
7392                     }
7393
7394                     goto unknown;
7395
7396                   default:
7397                     goto unknown;
7398                 }
7399               }
7400
7401               goto unknown;
7402
7403             case 'o':
7404               if (name[2] == 'c' &&
7405                   name[3] == 'k' &&
7406                   name[4] == 'e' &&
7407                   name[5] == 't')
7408               {                                   /* socket     */
7409                 return -KEY_socket;
7410               }
7411
7412               goto unknown;
7413
7414             case 'p':
7415               if (name[2] == 'l' &&
7416                   name[3] == 'i' &&
7417                   name[4] == 'c' &&
7418                   name[5] == 'e')
7419               {                                   /* splice     */
7420                 return -KEY_splice;
7421               }
7422
7423               goto unknown;
7424
7425             case 'u':
7426               if (name[2] == 'b' &&
7427                   name[3] == 's' &&
7428                   name[4] == 't' &&
7429                   name[5] == 'r')
7430               {                                   /* substr     */
7431                 return -KEY_substr;
7432               }
7433
7434               goto unknown;
7435
7436             case 'y':
7437               if (name[2] == 's' &&
7438                   name[3] == 't' &&
7439                   name[4] == 'e' &&
7440                   name[5] == 'm')
7441               {                                   /* system     */
7442                 return -KEY_system;
7443               }
7444
7445               goto unknown;
7446
7447             default:
7448               goto unknown;
7449           }
7450
7451         case 'u':
7452           if (name[1] == 'n')
7453           {
7454             switch (name[2])
7455             {
7456               case 'l':
7457                 switch (name[3])
7458                 {
7459                   case 'e':
7460                     if (name[4] == 's' &&
7461                         name[5] == 's')
7462                     {                             /* unless     */
7463                       return KEY_unless;
7464                     }
7465
7466                     goto unknown;
7467
7468                   case 'i':
7469                     if (name[4] == 'n' &&
7470                         name[5] == 'k')
7471                     {                             /* unlink     */
7472                       return -KEY_unlink;
7473                     }
7474
7475                     goto unknown;
7476
7477                   default:
7478                     goto unknown;
7479                 }
7480
7481               case 'p':
7482                 if (name[3] == 'a' &&
7483                     name[4] == 'c' &&
7484                     name[5] == 'k')
7485                 {                                 /* unpack     */
7486                   return -KEY_unpack;
7487                 }
7488
7489                 goto unknown;
7490
7491               default:
7492                 goto unknown;
7493             }
7494           }
7495
7496           goto unknown;
7497
7498         case 'v':
7499           if (name[1] == 'a' &&
7500               name[2] == 'l' &&
7501               name[3] == 'u' &&
7502               name[4] == 'e' &&
7503               name[5] == 's')
7504           {                                       /* values     */
7505             return -KEY_values;
7506           }
7507
7508           goto unknown;
7509
7510         default:
7511           goto unknown;
7512       }
7513
7514     case 7: /* 28 tokens of length 7 */
7515       switch (name[0])
7516       {
7517         case 'D':
7518           if (name[1] == 'E' &&
7519               name[2] == 'S' &&
7520               name[3] == 'T' &&
7521               name[4] == 'R' &&
7522               name[5] == 'O' &&
7523               name[6] == 'Y')
7524           {                                       /* DESTROY    */
7525             return KEY_DESTROY;
7526           }
7527
7528           goto unknown;
7529
7530         case '_':
7531           if (name[1] == '_' &&
7532               name[2] == 'E' &&
7533               name[3] == 'N' &&
7534               name[4] == 'D' &&
7535               name[5] == '_' &&
7536               name[6] == '_')
7537           {                                       /* __END__    */
7538             return KEY___END__;
7539           }
7540
7541           goto unknown;
7542
7543         case 'b':
7544           if (name[1] == 'i' &&
7545               name[2] == 'n' &&
7546               name[3] == 'm' &&
7547               name[4] == 'o' &&
7548               name[5] == 'd' &&
7549               name[6] == 'e')
7550           {                                       /* binmode    */
7551             return -KEY_binmode;
7552           }
7553
7554           goto unknown;
7555
7556         case 'c':
7557           if (name[1] == 'o' &&
7558               name[2] == 'n' &&
7559               name[3] == 'n' &&
7560               name[4] == 'e' &&
7561               name[5] == 'c' &&
7562               name[6] == 't')
7563           {                                       /* connect    */
7564             return -KEY_connect;
7565           }
7566
7567           goto unknown;
7568
7569         case 'd':
7570           switch (name[1])
7571           {
7572             case 'b':
7573               if (name[2] == 'm' &&
7574                   name[3] == 'o' &&
7575                   name[4] == 'p' &&
7576                   name[5] == 'e' &&
7577                   name[6] == 'n')
7578               {                                   /* dbmopen    */
7579                 return -KEY_dbmopen;
7580               }
7581
7582               goto unknown;
7583
7584             case 'e':
7585               if (name[2] == 'f' &&
7586                   name[3] == 'i' &&
7587                   name[4] == 'n' &&
7588                   name[5] == 'e' &&
7589                   name[6] == 'd')
7590               {                                   /* defined    */
7591                 return KEY_defined;
7592               }
7593
7594               goto unknown;
7595
7596             default:
7597               goto unknown;
7598           }
7599
7600         case 'f':
7601           if (name[1] == 'o' &&
7602               name[2] == 'r' &&
7603               name[3] == 'e' &&
7604               name[4] == 'a' &&
7605               name[5] == 'c' &&
7606               name[6] == 'h')
7607           {                                       /* foreach    */
7608             return KEY_foreach;
7609           }
7610
7611           goto unknown;
7612
7613         case 'g':
7614           if (name[1] == 'e' &&
7615               name[2] == 't' &&
7616               name[3] == 'p')
7617           {
7618             switch (name[4])
7619             {
7620               case 'g':
7621                 if (name[5] == 'r' &&
7622                     name[6] == 'p')
7623                 {                                 /* getpgrp    */
7624                   return -KEY_getpgrp;
7625                 }
7626
7627                 goto unknown;
7628
7629               case 'p':
7630                 if (name[5] == 'i' &&
7631                     name[6] == 'd')
7632                 {                                 /* getppid    */
7633                   return -KEY_getppid;
7634                 }
7635
7636                 goto unknown;
7637
7638               default:
7639                 goto unknown;
7640             }
7641           }
7642
7643           goto unknown;
7644
7645         case 'l':
7646           if (name[1] == 'c' &&
7647               name[2] == 'f' &&
7648               name[3] == 'i' &&
7649               name[4] == 'r' &&
7650               name[5] == 's' &&
7651               name[6] == 't')
7652           {                                       /* lcfirst    */
7653             return -KEY_lcfirst;
7654           }
7655
7656           goto unknown;
7657
7658         case 'o':
7659           if (name[1] == 'p' &&
7660               name[2] == 'e' &&
7661               name[3] == 'n' &&
7662               name[4] == 'd' &&
7663               name[5] == 'i' &&
7664               name[6] == 'r')
7665           {                                       /* opendir    */
7666             return -KEY_opendir;
7667           }
7668
7669           goto unknown;
7670
7671         case 'p':
7672           if (name[1] == 'a' &&
7673               name[2] == 'c' &&
7674               name[3] == 'k' &&
7675               name[4] == 'a' &&
7676               name[5] == 'g' &&
7677               name[6] == 'e')
7678           {                                       /* package    */
7679             return KEY_package;
7680           }
7681
7682           goto unknown;
7683
7684         case 'r':
7685           if (name[1] == 'e')
7686           {
7687             switch (name[2])
7688             {
7689               case 'a':
7690                 if (name[3] == 'd' &&
7691                     name[4] == 'd' &&
7692                     name[5] == 'i' &&
7693                     name[6] == 'r')
7694                 {                                 /* readdir    */
7695                   return -KEY_readdir;
7696                 }
7697
7698                 goto unknown;
7699
7700               case 'q':
7701                 if (name[3] == 'u' &&
7702                     name[4] == 'i' &&
7703                     name[5] == 'r' &&
7704                     name[6] == 'e')
7705                 {                                 /* require    */
7706                   return KEY_require;
7707                 }
7708
7709                 goto unknown;
7710
7711               case 'v':
7712                 if (name[3] == 'e' &&
7713                     name[4] == 'r' &&
7714                     name[5] == 's' &&
7715                     name[6] == 'e')
7716                 {                                 /* reverse    */
7717                   return -KEY_reverse;
7718                 }
7719
7720                 goto unknown;
7721
7722               default:
7723                 goto unknown;
7724             }
7725           }
7726
7727           goto unknown;
7728
7729         case 's':
7730           switch (name[1])
7731           {
7732             case 'e':
7733               switch (name[2])
7734               {
7735                 case 'e':
7736                   if (name[3] == 'k' &&
7737                       name[4] == 'd' &&
7738                       name[5] == 'i' &&
7739                       name[6] == 'r')
7740                   {                               /* seekdir    */
7741                     return -KEY_seekdir;
7742                   }
7743
7744                   goto unknown;
7745
7746                 case 't':
7747                   if (name[3] == 'p' &&
7748                       name[4] == 'g' &&
7749                       name[5] == 'r' &&
7750                       name[6] == 'p')
7751                   {                               /* setpgrp    */
7752                     return -KEY_setpgrp;
7753                   }
7754
7755                   goto unknown;
7756
7757                 default:
7758                   goto unknown;
7759               }
7760
7761             case 'h':
7762               if (name[2] == 'm' &&
7763                   name[3] == 'r' &&
7764                   name[4] == 'e' &&
7765                   name[5] == 'a' &&
7766                   name[6] == 'd')
7767               {                                   /* shmread    */
7768                 return -KEY_shmread;
7769               }
7770
7771               goto unknown;
7772
7773             case 'p':
7774               if (name[2] == 'r' &&
7775                   name[3] == 'i' &&
7776                   name[4] == 'n' &&
7777                   name[5] == 't' &&
7778                   name[6] == 'f')
7779               {                                   /* sprintf    */
7780                 return -KEY_sprintf;
7781               }
7782
7783               goto unknown;
7784
7785             case 'y':
7786               switch (name[2])
7787               {
7788                 case 'm':
7789                   if (name[3] == 'l' &&
7790                       name[4] == 'i' &&
7791                       name[5] == 'n' &&
7792                       name[6] == 'k')
7793                   {                               /* symlink    */
7794                     return -KEY_symlink;
7795                   }
7796
7797                   goto unknown;
7798
7799                 case 's':
7800                   switch (name[3])
7801                   {
7802                     case 'c':
7803                       if (name[4] == 'a' &&
7804                           name[5] == 'l' &&
7805                           name[6] == 'l')
7806                       {                           /* syscall    */
7807                         return -KEY_syscall;
7808                       }
7809
7810                       goto unknown;
7811
7812                     case 'o':
7813                       if (name[4] == 'p' &&
7814                           name[5] == 'e' &&
7815                           name[6] == 'n')
7816                       {                           /* sysopen    */
7817                         return -KEY_sysopen;
7818                       }
7819
7820                       goto unknown;
7821
7822                     case 'r':
7823                       if (name[4] == 'e' &&
7824                           name[5] == 'a' &&
7825                           name[6] == 'd')
7826                       {                           /* sysread    */
7827                         return -KEY_sysread;
7828                       }
7829
7830                       goto unknown;
7831
7832                     case 's':
7833                       if (name[4] == 'e' &&
7834                           name[5] == 'e' &&
7835                           name[6] == 'k')
7836                       {                           /* sysseek    */
7837                         return -KEY_sysseek;
7838                       }
7839
7840                       goto unknown;
7841
7842                     default:
7843                       goto unknown;
7844                   }
7845
7846                 default:
7847                   goto unknown;
7848               }
7849
7850             default:
7851               goto unknown;
7852           }
7853
7854         case 't':
7855           if (name[1] == 'e' &&
7856               name[2] == 'l' &&
7857               name[3] == 'l' &&
7858               name[4] == 'd' &&
7859               name[5] == 'i' &&
7860               name[6] == 'r')
7861           {                                       /* telldir    */
7862             return -KEY_telldir;
7863           }
7864
7865           goto unknown;
7866
7867         case 'u':
7868           switch (name[1])
7869           {
7870             case 'c':
7871               if (name[2] == 'f' &&
7872                   name[3] == 'i' &&
7873                   name[4] == 'r' &&
7874                   name[5] == 's' &&
7875                   name[6] == 't')
7876               {                                   /* ucfirst    */
7877                 return -KEY_ucfirst;
7878               }
7879
7880               goto unknown;
7881
7882             case 'n':
7883               if (name[2] == 's' &&
7884                   name[3] == 'h' &&
7885                   name[4] == 'i' &&
7886                   name[5] == 'f' &&
7887                   name[6] == 't')
7888               {                                   /* unshift    */
7889                 return -KEY_unshift;
7890               }
7891
7892               goto unknown;
7893
7894             default:
7895               goto unknown;
7896           }
7897
7898         case 'w':
7899           if (name[1] == 'a' &&
7900               name[2] == 'i' &&
7901               name[3] == 't' &&
7902               name[4] == 'p' &&
7903               name[5] == 'i' &&
7904               name[6] == 'd')
7905           {                                       /* waitpid    */
7906             return -KEY_waitpid;
7907           }
7908
7909           goto unknown;
7910
7911         default:
7912           goto unknown;
7913       }
7914
7915     case 8: /* 26 tokens of length 8 */
7916       switch (name[0])
7917       {
7918         case 'A':
7919           if (name[1] == 'U' &&
7920               name[2] == 'T' &&
7921               name[3] == 'O' &&
7922               name[4] == 'L' &&
7923               name[5] == 'O' &&
7924               name[6] == 'A' &&
7925               name[7] == 'D')
7926           {                                       /* AUTOLOAD   */
7927             return KEY_AUTOLOAD;
7928           }
7929
7930           goto unknown;
7931
7932         case '_':
7933           if (name[1] == '_')
7934           {
7935             switch (name[2])
7936             {
7937               case 'D':
7938                 if (name[3] == 'A' &&
7939                     name[4] == 'T' &&
7940                     name[5] == 'A' &&
7941                     name[6] == '_' &&
7942                     name[7] == '_')
7943                 {                                 /* __DATA__   */
7944                   return KEY___DATA__;
7945                 }
7946
7947                 goto unknown;
7948
7949               case 'F':
7950                 if (name[3] == 'I' &&
7951                     name[4] == 'L' &&
7952                     name[5] == 'E' &&
7953                     name[6] == '_' &&
7954                     name[7] == '_')
7955                 {                                 /* __FILE__   */
7956                   return -KEY___FILE__;
7957                 }
7958
7959                 goto unknown;
7960
7961               case 'L':
7962                 if (name[3] == 'I' &&
7963                     name[4] == 'N' &&
7964                     name[5] == 'E' &&
7965                     name[6] == '_' &&
7966                     name[7] == '_')
7967                 {                                 /* __LINE__   */
7968                   return -KEY___LINE__;
7969                 }
7970
7971                 goto unknown;
7972
7973               default:
7974                 goto unknown;
7975             }
7976           }
7977
7978           goto unknown;
7979
7980         case 'c':
7981           switch (name[1])
7982           {
7983             case 'l':
7984               if (name[2] == 'o' &&
7985                   name[3] == 's' &&
7986                   name[4] == 'e' &&
7987                   name[5] == 'd' &&
7988                   name[6] == 'i' &&
7989                   name[7] == 'r')
7990               {                                   /* closedir   */
7991                 return -KEY_closedir;
7992               }
7993
7994               goto unknown;
7995
7996             case 'o':
7997               if (name[2] == 'n' &&
7998                   name[3] == 't' &&
7999                   name[4] == 'i' &&
8000                   name[5] == 'n' &&
8001                   name[6] == 'u' &&
8002                   name[7] == 'e')
8003               {                                   /* continue   */
8004                 return -KEY_continue;
8005               }
8006
8007               goto unknown;
8008
8009             default:
8010               goto unknown;
8011           }
8012
8013         case 'd':
8014           if (name[1] == 'b' &&
8015               name[2] == 'm' &&
8016               name[3] == 'c' &&
8017               name[4] == 'l' &&
8018               name[5] == 'o' &&
8019               name[6] == 's' &&
8020               name[7] == 'e')
8021           {                                       /* dbmclose   */
8022             return -KEY_dbmclose;
8023           }
8024
8025           goto unknown;
8026
8027         case 'e':
8028           if (name[1] == 'n' &&
8029               name[2] == 'd')
8030           {
8031             switch (name[3])
8032             {
8033               case 'g':
8034                 if (name[4] == 'r' &&
8035                     name[5] == 'e' &&
8036                     name[6] == 'n' &&
8037                     name[7] == 't')
8038                 {                                 /* endgrent   */
8039                   return -KEY_endgrent;
8040                 }
8041
8042                 goto unknown;
8043
8044               case 'p':
8045                 if (name[4] == 'w' &&
8046                     name[5] == 'e' &&
8047                     name[6] == 'n' &&
8048                     name[7] == 't')
8049                 {                                 /* endpwent   */
8050                   return -KEY_endpwent;
8051                 }
8052
8053                 goto unknown;
8054
8055               default:
8056                 goto unknown;
8057             }
8058           }
8059
8060           goto unknown;
8061
8062         case 'f':
8063           if (name[1] == 'o' &&
8064               name[2] == 'r' &&
8065               name[3] == 'm' &&
8066               name[4] == 'l' &&
8067               name[5] == 'i' &&
8068               name[6] == 'n' &&
8069               name[7] == 'e')
8070           {                                       /* formline   */
8071             return -KEY_formline;
8072           }
8073
8074           goto unknown;
8075
8076         case 'g':
8077           if (name[1] == 'e' &&
8078               name[2] == 't')
8079           {
8080             switch (name[3])
8081             {
8082               case 'g':
8083                 if (name[4] == 'r')
8084                 {
8085                   switch (name[5])
8086                   {
8087                     case 'e':
8088                       if (name[6] == 'n' &&
8089                           name[7] == 't')
8090                       {                           /* getgrent   */
8091                         return -KEY_getgrent;
8092                       }
8093
8094                       goto unknown;
8095
8096                     case 'g':
8097                       if (name[6] == 'i' &&
8098                           name[7] == 'd')
8099                       {                           /* getgrgid   */
8100                         return -KEY_getgrgid;
8101                       }
8102
8103                       goto unknown;
8104
8105                     case 'n':
8106                       if (name[6] == 'a' &&
8107                           name[7] == 'm')
8108                       {                           /* getgrnam   */
8109                         return -KEY_getgrnam;
8110                       }
8111
8112                       goto unknown;
8113
8114                     default:
8115                       goto unknown;
8116                   }
8117                 }
8118
8119                 goto unknown;
8120
8121               case 'l':
8122                 if (name[4] == 'o' &&
8123                     name[5] == 'g' &&
8124                     name[6] == 'i' &&
8125                     name[7] == 'n')
8126                 {                                 /* getlogin   */
8127                   return -KEY_getlogin;
8128                 }
8129
8130                 goto unknown;
8131
8132               case 'p':
8133                 if (name[4] == 'w')
8134                 {
8135                   switch (name[5])
8136                   {
8137                     case 'e':
8138                       if (name[6] == 'n' &&
8139                           name[7] == 't')
8140                       {                           /* getpwent   */
8141                         return -KEY_getpwent;
8142                       }
8143
8144                       goto unknown;
8145
8146                     case 'n':
8147                       if (name[6] == 'a' &&
8148                           name[7] == 'm')
8149                       {                           /* getpwnam   */
8150                         return -KEY_getpwnam;
8151                       }
8152
8153                       goto unknown;
8154
8155                     case 'u':
8156                       if (name[6] == 'i' &&
8157                           name[7] == 'd')
8158                       {                           /* getpwuid   */
8159                         return -KEY_getpwuid;
8160                       }
8161
8162                       goto unknown;
8163
8164                     default:
8165                       goto unknown;
8166                   }
8167                 }
8168
8169                 goto unknown;
8170
8171               default:
8172                 goto unknown;
8173             }
8174           }
8175
8176           goto unknown;
8177
8178         case 'r':
8179           if (name[1] == 'e' &&
8180               name[2] == 'a' &&
8181               name[3] == 'd')
8182           {
8183             switch (name[4])
8184             {
8185               case 'l':
8186                 if (name[5] == 'i' &&
8187                     name[6] == 'n')
8188                 {
8189                   switch (name[7])
8190                   {
8191                     case 'e':
8192                       {                           /* readline   */
8193                         return -KEY_readline;
8194                       }
8195
8196                     case 'k':
8197                       {                           /* readlink   */
8198                         return -KEY_readlink;
8199                       }
8200
8201                     default:
8202                       goto unknown;
8203                   }
8204                 }
8205
8206                 goto unknown;
8207
8208               case 'p':
8209                 if (name[5] == 'i' &&
8210                     name[6] == 'p' &&
8211                     name[7] == 'e')
8212                 {                                 /* readpipe   */
8213                   return -KEY_readpipe;
8214                 }
8215
8216                 goto unknown;
8217
8218               default:
8219                 goto unknown;
8220             }
8221           }
8222
8223           goto unknown;
8224
8225         case 's':
8226           switch (name[1])
8227           {
8228             case 'e':
8229               if (name[2] == 't')
8230               {
8231                 switch (name[3])
8232                 {
8233                   case 'g':
8234                     if (name[4] == 'r' &&
8235                         name[5] == 'e' &&
8236                         name[6] == 'n' &&
8237                         name[7] == 't')
8238                     {                             /* setgrent   */
8239                       return -KEY_setgrent;
8240                     }
8241
8242                     goto unknown;
8243
8244                   case 'p':
8245                     if (name[4] == 'w' &&
8246                         name[5] == 'e' &&
8247                         name[6] == 'n' &&
8248                         name[7] == 't')
8249                     {                             /* setpwent   */
8250                       return -KEY_setpwent;
8251                     }
8252
8253                     goto unknown;
8254
8255                   default:
8256                     goto unknown;
8257                 }
8258               }
8259
8260               goto unknown;
8261
8262             case 'h':
8263               switch (name[2])
8264               {
8265                 case 'm':
8266                   if (name[3] == 'w' &&
8267                       name[4] == 'r' &&
8268                       name[5] == 'i' &&
8269                       name[6] == 't' &&
8270                       name[7] == 'e')
8271                   {                               /* shmwrite   */
8272                     return -KEY_shmwrite;
8273                   }
8274
8275                   goto unknown;
8276
8277                 case 'u':
8278                   if (name[3] == 't' &&
8279                       name[4] == 'd' &&
8280                       name[5] == 'o' &&
8281                       name[6] == 'w' &&
8282                       name[7] == 'n')
8283                   {                               /* shutdown   */
8284                     return -KEY_shutdown;
8285                   }
8286
8287                   goto unknown;
8288
8289                 default:
8290                   goto unknown;
8291               }
8292
8293             case 'y':
8294               if (name[2] == 's' &&
8295                   name[3] == 'w' &&
8296                   name[4] == 'r' &&
8297                   name[5] == 'i' &&
8298                   name[6] == 't' &&
8299                   name[7] == 'e')
8300               {                                   /* syswrite   */
8301                 return -KEY_syswrite;
8302               }
8303
8304               goto unknown;
8305
8306             default:
8307               goto unknown;
8308           }
8309
8310         case 't':
8311           if (name[1] == 'r' &&
8312               name[2] == 'u' &&
8313               name[3] == 'n' &&
8314               name[4] == 'c' &&
8315               name[5] == 'a' &&
8316               name[6] == 't' &&
8317               name[7] == 'e')
8318           {                                       /* truncate   */
8319             return -KEY_truncate;
8320           }
8321
8322           goto unknown;
8323
8324         default:
8325           goto unknown;
8326       }
8327
8328     case 9: /* 8 tokens of length 9 */
8329       switch (name[0])
8330       {
8331         case 'e':
8332           if (name[1] == 'n' &&
8333               name[2] == 'd' &&
8334               name[3] == 'n' &&
8335               name[4] == 'e' &&
8336               name[5] == 't' &&
8337               name[6] == 'e' &&
8338               name[7] == 'n' &&
8339               name[8] == 't')
8340           {                                       /* endnetent  */
8341             return -KEY_endnetent;
8342           }
8343
8344           goto unknown;
8345
8346         case 'g':
8347           if (name[1] == 'e' &&
8348               name[2] == 't' &&
8349               name[3] == 'n' &&
8350               name[4] == 'e' &&
8351               name[5] == 't' &&
8352               name[6] == 'e' &&
8353               name[7] == 'n' &&
8354               name[8] == 't')
8355           {                                       /* getnetent  */
8356             return -KEY_getnetent;
8357           }
8358
8359           goto unknown;
8360
8361         case 'l':
8362           if (name[1] == 'o' &&
8363               name[2] == 'c' &&
8364               name[3] == 'a' &&
8365               name[4] == 'l' &&
8366               name[5] == 't' &&
8367               name[6] == 'i' &&
8368               name[7] == 'm' &&
8369               name[8] == 'e')
8370           {                                       /* localtime  */
8371             return -KEY_localtime;
8372           }
8373
8374           goto unknown;
8375
8376         case 'p':
8377           if (name[1] == 'r' &&
8378               name[2] == 'o' &&
8379               name[3] == 't' &&
8380               name[4] == 'o' &&
8381               name[5] == 't' &&
8382               name[6] == 'y' &&
8383               name[7] == 'p' &&
8384               name[8] == 'e')
8385           {                                       /* prototype  */
8386             return KEY_prototype;
8387           }
8388
8389           goto unknown;
8390
8391         case 'q':
8392           if (name[1] == 'u' &&
8393               name[2] == 'o' &&
8394               name[3] == 't' &&
8395               name[4] == 'e' &&
8396               name[5] == 'm' &&
8397               name[6] == 'e' &&
8398               name[7] == 't' &&
8399               name[8] == 'a')
8400           {                                       /* quotemeta  */
8401             return -KEY_quotemeta;
8402           }
8403
8404           goto unknown;
8405
8406         case 'r':
8407           if (name[1] == 'e' &&
8408               name[2] == 'w' &&
8409               name[3] == 'i' &&
8410               name[4] == 'n' &&
8411               name[5] == 'd' &&
8412               name[6] == 'd' &&
8413               name[7] == 'i' &&
8414               name[8] == 'r')
8415           {                                       /* rewinddir  */
8416             return -KEY_rewinddir;
8417           }
8418
8419           goto unknown;
8420
8421         case 's':
8422           if (name[1] == 'e' &&
8423               name[2] == 't' &&
8424               name[3] == 'n' &&
8425               name[4] == 'e' &&
8426               name[5] == 't' &&
8427               name[6] == 'e' &&
8428               name[7] == 'n' &&
8429               name[8] == 't')
8430           {                                       /* setnetent  */
8431             return -KEY_setnetent;
8432           }
8433
8434           goto unknown;
8435
8436         case 'w':
8437           if (name[1] == 'a' &&
8438               name[2] == 'n' &&
8439               name[3] == 't' &&
8440               name[4] == 'a' &&
8441               name[5] == 'r' &&
8442               name[6] == 'r' &&
8443               name[7] == 'a' &&
8444               name[8] == 'y')
8445           {                                       /* wantarray  */
8446             return -KEY_wantarray;
8447           }
8448
8449           goto unknown;
8450
8451         default:
8452           goto unknown;
8453       }
8454
8455     case 10: /* 9 tokens of length 10 */
8456       switch (name[0])
8457       {
8458         case 'e':
8459           if (name[1] == 'n' &&
8460               name[2] == 'd')
8461           {
8462             switch (name[3])
8463             {
8464               case 'h':
8465                 if (name[4] == 'o' &&
8466                     name[5] == 's' &&
8467                     name[6] == 't' &&
8468                     name[7] == 'e' &&
8469                     name[8] == 'n' &&
8470                     name[9] == 't')
8471                 {                                 /* endhostent */
8472                   return -KEY_endhostent;
8473                 }
8474
8475                 goto unknown;
8476
8477               case 's':
8478                 if (name[4] == 'e' &&
8479                     name[5] == 'r' &&
8480                     name[6] == 'v' &&
8481                     name[7] == 'e' &&
8482                     name[8] == 'n' &&
8483                     name[9] == 't')
8484                 {                                 /* endservent */
8485                   return -KEY_endservent;
8486                 }
8487
8488                 goto unknown;
8489
8490               default:
8491                 goto unknown;
8492             }
8493           }
8494
8495           goto unknown;
8496
8497         case 'g':
8498           if (name[1] == 'e' &&
8499               name[2] == 't')
8500           {
8501             switch (name[3])
8502             {
8503               case 'h':
8504                 if (name[4] == 'o' &&
8505                     name[5] == 's' &&
8506                     name[6] == 't' &&
8507                     name[7] == 'e' &&
8508                     name[8] == 'n' &&
8509                     name[9] == 't')
8510                 {                                 /* gethostent */
8511                   return -KEY_gethostent;
8512                 }
8513
8514                 goto unknown;
8515
8516               case 's':
8517                 switch (name[4])
8518                 {
8519                   case 'e':
8520                     if (name[5] == 'r' &&
8521                         name[6] == 'v' &&
8522                         name[7] == 'e' &&
8523                         name[8] == 'n' &&
8524                         name[9] == 't')
8525                     {                             /* getservent */
8526                       return -KEY_getservent;
8527                     }
8528
8529                     goto unknown;
8530
8531                   case 'o':
8532                     if (name[5] == 'c' &&
8533                         name[6] == 'k' &&
8534                         name[7] == 'o' &&
8535                         name[8] == 'p' &&
8536                         name[9] == 't')
8537                     {                             /* getsockopt */
8538                       return -KEY_getsockopt;
8539                     }
8540
8541                     goto unknown;
8542
8543                   default:
8544                     goto unknown;
8545                 }
8546
8547               default:
8548                 goto unknown;
8549             }
8550           }
8551
8552           goto unknown;
8553
8554         case 's':
8555           switch (name[1])
8556           {
8557             case 'e':
8558               if (name[2] == 't')
8559               {
8560                 switch (name[3])
8561                 {
8562                   case 'h':
8563                     if (name[4] == 'o' &&
8564                         name[5] == 's' &&
8565                         name[6] == 't' &&
8566                         name[7] == 'e' &&
8567                         name[8] == 'n' &&
8568                         name[9] == 't')
8569                     {                             /* sethostent */
8570                       return -KEY_sethostent;
8571                     }
8572
8573                     goto unknown;
8574
8575                   case 's':
8576                     switch (name[4])
8577                     {
8578                       case 'e':
8579                         if (name[5] == 'r' &&
8580                             name[6] == 'v' &&
8581                             name[7] == 'e' &&
8582                             name[8] == 'n' &&
8583                             name[9] == 't')
8584                         {                         /* setservent */
8585                           return -KEY_setservent;
8586                         }
8587
8588                         goto unknown;
8589
8590                       case 'o':
8591                         if (name[5] == 'c' &&
8592                             name[6] == 'k' &&
8593                             name[7] == 'o' &&
8594                             name[8] == 'p' &&
8595                             name[9] == 't')
8596                         {                         /* setsockopt */
8597                           return -KEY_setsockopt;
8598                         }
8599
8600                         goto unknown;
8601
8602                       default:
8603                         goto unknown;
8604                     }
8605
8606                   default:
8607                     goto unknown;
8608                 }
8609               }
8610
8611               goto unknown;
8612
8613             case 'o':
8614               if (name[2] == 'c' &&
8615                   name[3] == 'k' &&
8616                   name[4] == 'e' &&
8617                   name[5] == 't' &&
8618                   name[6] == 'p' &&
8619                   name[7] == 'a' &&
8620                   name[8] == 'i' &&
8621                   name[9] == 'r')
8622               {                                   /* socketpair */
8623                 return -KEY_socketpair;
8624               }
8625
8626               goto unknown;
8627
8628             default:
8629               goto unknown;
8630           }
8631
8632         default:
8633           goto unknown;
8634       }
8635
8636     case 11: /* 8 tokens of length 11 */
8637       switch (name[0])
8638       {
8639         case '_':
8640           if (name[1] == '_' &&
8641               name[2] == 'P' &&
8642               name[3] == 'A' &&
8643               name[4] == 'C' &&
8644               name[5] == 'K' &&
8645               name[6] == 'A' &&
8646               name[7] == 'G' &&
8647               name[8] == 'E' &&
8648               name[9] == '_' &&
8649               name[10] == '_')
8650           {                                       /* __PACKAGE__ */
8651             return -KEY___PACKAGE__;
8652           }
8653
8654           goto unknown;
8655
8656         case 'e':
8657           if (name[1] == 'n' &&
8658               name[2] == 'd' &&
8659               name[3] == 'p' &&
8660               name[4] == 'r' &&
8661               name[5] == 'o' &&
8662               name[6] == 't' &&
8663               name[7] == 'o' &&
8664               name[8] == 'e' &&
8665               name[9] == 'n' &&
8666               name[10] == 't')
8667           {                                       /* endprotoent */
8668             return -KEY_endprotoent;
8669           }
8670
8671           goto unknown;
8672
8673         case 'g':
8674           if (name[1] == 'e' &&
8675               name[2] == 't')
8676           {
8677             switch (name[3])
8678             {
8679               case 'p':
8680                 switch (name[4])
8681                 {
8682                   case 'e':
8683                     if (name[5] == 'e' &&
8684                         name[6] == 'r' &&
8685                         name[7] == 'n' &&
8686                         name[8] == 'a' &&
8687                         name[9] == 'm' &&
8688                         name[10] == 'e')
8689                     {                             /* getpeername */
8690                       return -KEY_getpeername;
8691                     }
8692
8693                     goto unknown;
8694
8695                   case 'r':
8696                     switch (name[5])
8697                     {
8698                       case 'i':
8699                         if (name[6] == 'o' &&
8700                             name[7] == 'r' &&
8701                             name[8] == 'i' &&
8702                             name[9] == 't' &&
8703                             name[10] == 'y')
8704                         {                         /* getpriority */
8705                           return -KEY_getpriority;
8706                         }
8707
8708                         goto unknown;
8709
8710                       case 'o':
8711                         if (name[6] == 't' &&
8712                             name[7] == 'o' &&
8713                             name[8] == 'e' &&
8714                             name[9] == 'n' &&
8715                             name[10] == 't')
8716                         {                         /* getprotoent */
8717                           return -KEY_getprotoent;
8718                         }
8719
8720                         goto unknown;
8721
8722                       default:
8723                         goto unknown;
8724                     }
8725
8726                   default:
8727                     goto unknown;
8728                 }
8729
8730               case 's':
8731                 if (name[4] == 'o' &&
8732                     name[5] == 'c' &&
8733                     name[6] == 'k' &&
8734                     name[7] == 'n' &&
8735                     name[8] == 'a' &&
8736                     name[9] == 'm' &&
8737                     name[10] == 'e')
8738                 {                                 /* getsockname */
8739                   return -KEY_getsockname;
8740                 }
8741
8742                 goto unknown;
8743
8744               default:
8745                 goto unknown;
8746             }
8747           }
8748
8749           goto unknown;
8750
8751         case 's':
8752           if (name[1] == 'e' &&
8753               name[2] == 't' &&
8754               name[3] == 'p' &&
8755               name[4] == 'r')
8756           {
8757             switch (name[5])
8758             {
8759               case 'i':
8760                 if (name[6] == 'o' &&
8761                     name[7] == 'r' &&
8762                     name[8] == 'i' &&
8763                     name[9] == 't' &&
8764                     name[10] == 'y')
8765                 {                                 /* setpriority */
8766                   return -KEY_setpriority;
8767                 }
8768
8769                 goto unknown;
8770
8771               case 'o':
8772                 if (name[6] == 't' &&
8773                     name[7] == 'o' &&
8774                     name[8] == 'e' &&
8775                     name[9] == 'n' &&
8776                     name[10] == 't')
8777                 {                                 /* setprotoent */
8778                   return -KEY_setprotoent;
8779                 }
8780
8781                 goto unknown;
8782
8783               default:
8784                 goto unknown;
8785             }
8786           }
8787
8788           goto unknown;
8789
8790         default:
8791           goto unknown;
8792       }
8793
8794     case 12: /* 2 tokens of length 12 */
8795       if (name[0] == 'g' &&
8796           name[1] == 'e' &&
8797           name[2] == 't' &&
8798           name[3] == 'n' &&
8799           name[4] == 'e' &&
8800           name[5] == 't' &&
8801           name[6] == 'b' &&
8802           name[7] == 'y')
8803       {
8804         switch (name[8])
8805         {
8806           case 'a':
8807             if (name[9] == 'd' &&
8808                 name[10] == 'd' &&
8809                 name[11] == 'r')
8810             {                                     /* getnetbyaddr */
8811               return -KEY_getnetbyaddr;
8812             }
8813
8814             goto unknown;
8815
8816           case 'n':
8817             if (name[9] == 'a' &&
8818                 name[10] == 'm' &&
8819                 name[11] == 'e')
8820             {                                     /* getnetbyname */
8821               return -KEY_getnetbyname;
8822             }
8823
8824             goto unknown;
8825
8826           default:
8827             goto unknown;
8828         }
8829       }
8830
8831       goto unknown;
8832
8833     case 13: /* 4 tokens of length 13 */
8834       if (name[0] == 'g' &&
8835           name[1] == 'e' &&
8836           name[2] == 't')
8837       {
8838         switch (name[3])
8839         {
8840           case 'h':
8841             if (name[4] == 'o' &&
8842                 name[5] == 's' &&
8843                 name[6] == 't' &&
8844                 name[7] == 'b' &&
8845                 name[8] == 'y')
8846             {
8847               switch (name[9])
8848               {
8849                 case 'a':
8850                   if (name[10] == 'd' &&
8851                       name[11] == 'd' &&
8852                       name[12] == 'r')
8853                   {                               /* gethostbyaddr */
8854                     return -KEY_gethostbyaddr;
8855                   }
8856
8857                   goto unknown;
8858
8859                 case 'n':
8860                   if (name[10] == 'a' &&
8861                       name[11] == 'm' &&
8862                       name[12] == 'e')
8863                   {                               /* gethostbyname */
8864                     return -KEY_gethostbyname;
8865                   }
8866
8867                   goto unknown;
8868
8869                 default:
8870                   goto unknown;
8871               }
8872             }
8873
8874             goto unknown;
8875
8876           case 's':
8877             if (name[4] == 'e' &&
8878                 name[5] == 'r' &&
8879                 name[6] == 'v' &&
8880                 name[7] == 'b' &&
8881                 name[8] == 'y')
8882             {
8883               switch (name[9])
8884               {
8885                 case 'n':
8886                   if (name[10] == 'a' &&
8887                       name[11] == 'm' &&
8888                       name[12] == 'e')
8889                   {                               /* getservbyname */
8890                     return -KEY_getservbyname;
8891                   }
8892
8893                   goto unknown;
8894
8895                 case 'p':
8896                   if (name[10] == 'o' &&
8897                       name[11] == 'r' &&
8898                       name[12] == 't')
8899                   {                               /* getservbyport */
8900                     return -KEY_getservbyport;
8901                   }
8902
8903                   goto unknown;
8904
8905                 default:
8906                   goto unknown;
8907               }
8908             }
8909
8910             goto unknown;
8911
8912           default:
8913             goto unknown;
8914         }
8915       }
8916
8917       goto unknown;
8918
8919     case 14: /* 1 tokens of length 14 */
8920       if (name[0] == 'g' &&
8921           name[1] == 'e' &&
8922           name[2] == 't' &&
8923           name[3] == 'p' &&
8924           name[4] == 'r' &&
8925           name[5] == 'o' &&
8926           name[6] == 't' &&
8927           name[7] == 'o' &&
8928           name[8] == 'b' &&
8929           name[9] == 'y' &&
8930           name[10] == 'n' &&
8931           name[11] == 'a' &&
8932           name[12] == 'm' &&
8933           name[13] == 'e')
8934       {                                           /* getprotobyname */
8935         return -KEY_getprotobyname;
8936       }
8937
8938       goto unknown;
8939
8940     case 16: /* 1 tokens of length 16 */
8941       if (name[0] == 'g' &&
8942           name[1] == 'e' &&
8943           name[2] == 't' &&
8944           name[3] == 'p' &&
8945           name[4] == 'r' &&
8946           name[5] == 'o' &&
8947           name[6] == 't' &&
8948           name[7] == 'o' &&
8949           name[8] == 'b' &&
8950           name[9] == 'y' &&
8951           name[10] == 'n' &&
8952           name[11] == 'u' &&
8953           name[12] == 'm' &&
8954           name[13] == 'b' &&
8955           name[14] == 'e' &&
8956           name[15] == 'r')
8957       {                                           /* getprotobynumber */
8958         return -KEY_getprotobynumber;
8959       }
8960
8961       goto unknown;
8962
8963     default:
8964       goto unknown;
8965   }
8966
8967 unknown:
8968   return 0;
8969 }
8970
8971 STATIC void
8972 S_checkcomma(pTHX_ register char *s, const char *name, const char *what)
8973 {
8974     const char *w;
8975
8976     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
8977         if (ckWARN(WARN_SYNTAX)) {
8978             int level = 1;
8979             for (w = s+2; *w && level; w++) {
8980                 if (*w == '(')
8981                     ++level;
8982                 else if (*w == ')')
8983                     --level;
8984             }
8985             if (*w)
8986                 for (; *w && isSPACE(*w); w++) ;
8987             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
8988                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
8989                             "%s (...) interpreted as function",name);
8990         }
8991     }
8992     while (s < PL_bufend && isSPACE(*s))
8993         s++;
8994     if (*s == '(')
8995         s++;
8996     while (s < PL_bufend && isSPACE(*s))
8997         s++;
8998     if (isIDFIRST_lazy_if(s,UTF)) {
8999         w = s++;
9000         while (isALNUM_lazy_if(s,UTF))
9001             s++;
9002         while (s < PL_bufend && isSPACE(*s))
9003             s++;
9004         if (*s == ',') {
9005             int kw;
9006             *s = '\0'; /* XXX If we didn't do this, we could const a lot of toke.c */
9007             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
9008             *s = ',';
9009             if (kw)
9010                 return;
9011             Perl_croak(aTHX_ "No comma allowed after %s", what);
9012         }
9013     }
9014 }
9015
9016 /* Either returns sv, or mortalizes sv and returns a new SV*.
9017    Best used as sv=new_constant(..., sv, ...).
9018    If s, pv are NULL, calls subroutine with one argument,
9019    and type is used with error messages only. */
9020
9021 STATIC SV *
9022 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
9023                const char *type)
9024 {
9025     dVAR; dSP;
9026     HV * const table = GvHV(PL_hintgv);          /* ^H */
9027     SV *res;
9028     SV **cvp;
9029     SV *cv, *typesv;
9030     const char *why1 = "", *why2 = "", *why3 = "";
9031
9032     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
9033         SV *msg;
9034         
9035         why2 = strEQ(key,"charnames")
9036                ? "(possibly a missing \"use charnames ...\")"
9037                : "";
9038         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
9039                             (type ? type: "undef"), why2);
9040
9041         /* This is convoluted and evil ("goto considered harmful")
9042          * but I do not understand the intricacies of all the different
9043          * failure modes of %^H in here.  The goal here is to make
9044          * the most probable error message user-friendly. --jhi */
9045
9046         goto msgdone;
9047
9048     report:
9049         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
9050                             (type ? type: "undef"), why1, why2, why3);
9051     msgdone:
9052         yyerror(SvPVX_const(msg));
9053         SvREFCNT_dec(msg);
9054         return sv;
9055     }
9056     cvp = hv_fetch(table, key, strlen(key), FALSE);
9057     if (!cvp || !SvOK(*cvp)) {
9058         why1 = "$^H{";
9059         why2 = key;
9060         why3 = "} is not defined";
9061         goto report;
9062     }
9063     sv_2mortal(sv);                     /* Parent created it permanently */
9064     cv = *cvp;
9065     if (!pv && s)
9066         pv = sv_2mortal(newSVpvn(s, len));
9067     if (type && pv)
9068         typesv = sv_2mortal(newSVpv(type, 0));
9069     else
9070         typesv = &PL_sv_undef;
9071
9072     PUSHSTACKi(PERLSI_OVERLOAD);
9073     ENTER ;
9074     SAVETMPS;
9075
9076     PUSHMARK(SP) ;
9077     EXTEND(sp, 3);
9078     if (pv)
9079         PUSHs(pv);
9080     PUSHs(sv);
9081     if (pv)
9082         PUSHs(typesv);
9083     PUTBACK;
9084     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
9085
9086     SPAGAIN ;
9087
9088     /* Check the eval first */
9089     if (!PL_in_eval && SvTRUE(ERRSV)) {
9090         sv_catpv(ERRSV, "Propagated");
9091         yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
9092         (void)POPs;
9093         res = SvREFCNT_inc(sv);
9094     }
9095     else {
9096         res = POPs;
9097         (void)SvREFCNT_inc(res);
9098     }
9099
9100     PUTBACK ;
9101     FREETMPS ;
9102     LEAVE ;
9103     POPSTACK;
9104
9105     if (!SvOK(res)) {
9106         why1 = "Call to &{$^H{";
9107         why2 = key;
9108         why3 = "}} did not return a defined value";
9109         sv = res;
9110         goto report;
9111     }
9112
9113     return res;
9114 }
9115
9116 /* Returns a NUL terminated string, with the length of the string written to
9117    *slp
9118    */
9119 STATIC char *
9120 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
9121 {
9122     register char *d = dest;
9123     register char * const e = d + destlen - 3;  /* two-character token, ending NUL */
9124     for (;;) {
9125         if (d >= e)
9126             Perl_croak(aTHX_ ident_too_long);
9127         if (isALNUM(*s))        /* UTF handled below */
9128             *d++ = *s++;
9129         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
9130             *d++ = ':';
9131             *d++ = ':';
9132             s++;
9133         }
9134         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
9135             *d++ = *s++;
9136             *d++ = *s++;
9137         }
9138         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9139             char *t = s + UTF8SKIP(s);
9140             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9141                 t += UTF8SKIP(t);
9142             if (d + (t - s) > e)
9143                 Perl_croak(aTHX_ ident_too_long);
9144             Copy(s, d, t - s, char);
9145             d += t - s;
9146             s = t;
9147         }
9148         else {
9149             *d = '\0';
9150             *slp = d - dest;
9151             return s;
9152         }
9153     }
9154 }
9155
9156 STATIC char *
9157 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
9158 {
9159     register char *d;
9160     register char *e;
9161     char *bracket = Nullch;
9162     char funny = *s++;
9163
9164     if (isSPACE(*s))
9165         s = skipspace(s);
9166     d = dest;
9167     e = d + destlen - 3;        /* two-character token, ending NUL */
9168     if (isDIGIT(*s)) {
9169         while (isDIGIT(*s)) {
9170             if (d >= e)
9171                 Perl_croak(aTHX_ ident_too_long);
9172             *d++ = *s++;
9173         }
9174     }
9175     else {
9176         for (;;) {
9177             if (d >= e)
9178                 Perl_croak(aTHX_ ident_too_long);
9179             if (isALNUM(*s))    /* UTF handled below */
9180                 *d++ = *s++;
9181             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
9182                 *d++ = ':';
9183                 *d++ = ':';
9184                 s++;
9185             }
9186             else if (*s == ':' && s[1] == ':') {
9187                 *d++ = *s++;
9188                 *d++ = *s++;
9189             }
9190             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
9191                 char *t = s + UTF8SKIP(s);
9192                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
9193                     t += UTF8SKIP(t);
9194                 if (d + (t - s) > e)
9195                     Perl_croak(aTHX_ ident_too_long);
9196                 Copy(s, d, t - s, char);
9197                 d += t - s;
9198                 s = t;
9199             }
9200             else
9201                 break;
9202         }
9203     }
9204     *d = '\0';
9205     d = dest;
9206     if (*d) {
9207         if (PL_lex_state != LEX_NORMAL)
9208             PL_lex_state = LEX_INTERPENDMAYBE;
9209         return s;
9210     }
9211     if (*s == '$' && s[1] &&
9212         (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
9213     {
9214         return s;
9215     }
9216     if (*s == '{') {
9217         bracket = s;
9218         s++;
9219     }
9220     else if (ck_uni)
9221         check_uni();
9222     if (s < send)
9223         *d = *s++;
9224     d[1] = '\0';
9225     if (*d == '^' && *s && isCONTROLVAR(*s)) {
9226         *d = toCTRL(*s);
9227         s++;
9228     }
9229     if (bracket) {
9230         if (isSPACE(s[-1])) {
9231             while (s < send) {
9232                 const char ch = *s++;
9233                 if (!SPACE_OR_TAB(ch)) {
9234                     *d = ch;
9235                     break;
9236                 }
9237             }
9238         }
9239         if (isIDFIRST_lazy_if(d,UTF)) {
9240             d++;
9241             if (UTF) {
9242                 e = s;
9243                 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
9244                     e += UTF8SKIP(e);
9245                     while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
9246                         e += UTF8SKIP(e);
9247                 }
9248                 Copy(s, d, e - s, char);
9249                 d += e - s;
9250                 s = e;
9251             }
9252             else {
9253                 while ((isALNUM(*s) || *s == ':') && d < e)
9254                     *d++ = *s++;
9255                 if (d >= e)
9256                     Perl_croak(aTHX_ ident_too_long);
9257             }
9258             *d = '\0';
9259             while (s < send && SPACE_OR_TAB(*s)) s++;
9260             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
9261                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
9262                     const char *brack = *s == '[' ? "[...]" : "{...}";
9263                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9264                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
9265                         funny, dest, brack, funny, dest, brack);
9266                 }
9267                 bracket++;
9268                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
9269                 return s;
9270             }
9271         }
9272         /* Handle extended ${^Foo} variables
9273          * 1999-02-27 mjd-perl-patch@plover.com */
9274         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
9275                  && isALNUM(*s))
9276         {
9277             d++;
9278             while (isALNUM(*s) && d < e) {
9279                 *d++ = *s++;
9280             }
9281             if (d >= e)
9282                 Perl_croak(aTHX_ ident_too_long);
9283             *d = '\0';
9284         }
9285         if (*s == '}') {
9286             s++;
9287             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
9288                 PL_lex_state = LEX_INTERPEND;
9289                 PL_expect = XREF;
9290             }
9291             if (funny == '#')
9292                 funny = '@';
9293             if (PL_lex_state == LEX_NORMAL) {
9294                 if (ckWARN(WARN_AMBIGUOUS) &&
9295                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
9296                 {
9297                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
9298                         "Ambiguous use of %c{%s} resolved to %c%s",
9299                         funny, dest, funny, dest);
9300                 }
9301             }
9302         }
9303         else {
9304             s = bracket;                /* let the parser handle it */
9305             *dest = '\0';
9306         }
9307     }
9308     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
9309         PL_lex_state = LEX_INTERPEND;
9310     return s;
9311 }
9312
9313 void
9314 Perl_pmflag(pTHX_ U32* pmfl, int ch)
9315 {
9316     if (ch == 'i')
9317         *pmfl |= PMf_FOLD;
9318     else if (ch == 'g')
9319         *pmfl |= PMf_GLOBAL;
9320     else if (ch == 'c')
9321         *pmfl |= PMf_CONTINUE;
9322     else if (ch == 'o')
9323         *pmfl |= PMf_KEEP;
9324     else if (ch == 'm')
9325         *pmfl |= PMf_MULTILINE;
9326     else if (ch == 's')
9327         *pmfl |= PMf_SINGLELINE;
9328     else if (ch == 'x')
9329         *pmfl |= PMf_EXTENDED;
9330 }
9331
9332 STATIC char *
9333 S_scan_pat(pTHX_ char *start, I32 type)
9334 {
9335     PMOP *pm;
9336     char *s = scan_str(start,FALSE,FALSE);
9337
9338     if (!s) {
9339         char * const delimiter = skipspace(start);
9340         Perl_croak(aTHX_ *delimiter == '?'
9341                    ? "Search pattern not terminated or ternary operator parsed as search pattern"
9342                    : "Search pattern not terminated" );
9343     }
9344
9345     pm = (PMOP*)newPMOP(type, 0);
9346     if (PL_multi_open == '?')
9347         pm->op_pmflags |= PMf_ONCE;
9348     if(type == OP_QR) {
9349         while (*s && strchr("iomsx", *s))
9350             pmflag(&pm->op_pmflags,*s++);
9351     }
9352     else {
9353         while (*s && strchr("iogcmsx", *s))
9354             pmflag(&pm->op_pmflags,*s++);
9355     }
9356     /* issue a warning if /c is specified,but /g is not */
9357     if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
9358             && ckWARN(WARN_REGEXP))
9359     {
9360         Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
9361     }
9362
9363     pm->op_pmpermflags = pm->op_pmflags;
9364
9365     PL_lex_op = (OP*)pm;
9366     yylval.ival = OP_MATCH;
9367     return s;
9368 }
9369
9370 STATIC char *
9371 S_scan_subst(pTHX_ char *start)
9372 {
9373     dVAR;
9374     register char *s;
9375     register PMOP *pm;
9376     I32 first_start;
9377     I32 es = 0;
9378
9379     yylval.ival = OP_NULL;
9380
9381     s = scan_str(start,FALSE,FALSE);
9382
9383     if (!s)
9384         Perl_croak(aTHX_ "Substitution pattern not terminated");
9385
9386     if (s[-1] == PL_multi_open)
9387         s--;
9388
9389     first_start = PL_multi_start;
9390     s = scan_str(s,FALSE,FALSE);
9391     if (!s) {
9392         if (PL_lex_stuff) {
9393             SvREFCNT_dec(PL_lex_stuff);
9394             PL_lex_stuff = Nullsv;
9395         }
9396         Perl_croak(aTHX_ "Substitution replacement not terminated");
9397     }
9398     PL_multi_start = first_start;       /* so whole substitution is taken together */
9399
9400     pm = (PMOP*)newPMOP(OP_SUBST, 0);
9401     while (*s) {
9402         if (*s == 'e') {
9403             s++;
9404             es++;
9405         }
9406         else if (strchr("iogcmsx", *s))
9407             pmflag(&pm->op_pmflags,*s++);
9408         else
9409             break;
9410     }
9411
9412     /* /c is not meaningful with s/// */
9413     if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP))
9414     {
9415         Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
9416     }
9417
9418     if (es) {
9419         SV *repl;
9420         PL_sublex_info.super_bufptr = s;
9421         PL_sublex_info.super_bufend = PL_bufend;
9422         PL_multi_end = 0;
9423         pm->op_pmflags |= PMf_EVAL;
9424         repl = newSVpvn("",0);
9425         while (es-- > 0)
9426             sv_catpv(repl, es ? "eval " : "do ");
9427         sv_catpvn(repl, "{ ", 2);
9428         sv_catsv(repl, PL_lex_repl);
9429         sv_catpvn(repl, " };", 2);
9430         SvEVALED_on(repl);
9431         SvREFCNT_dec(PL_lex_repl);
9432         PL_lex_repl = repl;
9433     }
9434
9435     pm->op_pmpermflags = pm->op_pmflags;
9436     PL_lex_op = (OP*)pm;
9437     yylval.ival = OP_SUBST;
9438     return s;
9439 }
9440
9441 STATIC char *
9442 S_scan_trans(pTHX_ char *start)
9443 {
9444     register char* s;
9445     OP *o;
9446     short *tbl;
9447     I32 squash;
9448     I32 del;
9449     I32 complement;
9450
9451     yylval.ival = OP_NULL;
9452
9453     s = scan_str(start,FALSE,FALSE);
9454     if (!s)
9455         Perl_croak(aTHX_ "Transliteration pattern not terminated");
9456     if (s[-1] == PL_multi_open)
9457         s--;
9458
9459     s = scan_str(s,FALSE,FALSE);
9460     if (!s) {
9461         if (PL_lex_stuff) {
9462             SvREFCNT_dec(PL_lex_stuff);
9463             PL_lex_stuff = Nullsv;
9464         }
9465         Perl_croak(aTHX_ "Transliteration replacement not terminated");
9466     }
9467
9468     complement = del = squash = 0;
9469     while (1) {
9470         switch (*s) {
9471         case 'c':
9472             complement = OPpTRANS_COMPLEMENT;
9473             break;
9474         case 'd':
9475             del = OPpTRANS_DELETE;
9476             break;
9477         case 's':
9478             squash = OPpTRANS_SQUASH;
9479             break;
9480         default:
9481             goto no_more;
9482         }
9483         s++;
9484     }
9485   no_more:
9486
9487     Newx(tbl, complement&&!del?258:256, short);
9488     o = newPVOP(OP_TRANS, 0, (char*)tbl);
9489     o->op_private &= ~OPpTRANS_ALL;
9490     o->op_private |= del|squash|complement|
9491       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
9492       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
9493
9494     PL_lex_op = o;
9495     yylval.ival = OP_TRANS;
9496     return s;
9497 }
9498
9499 STATIC char *
9500 S_scan_heredoc(pTHX_ register char *s)
9501 {
9502     SV *herewas;
9503     I32 op_type = OP_SCALAR;
9504     I32 len;
9505     SV *tmpstr;
9506     char term;
9507     const char newline[] = "\n";
9508     const char *found_newline;
9509     register char *d;
9510     register char *e;
9511     char *peek;
9512     const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
9513
9514     s += 2;
9515     d = PL_tokenbuf;
9516     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
9517     if (!outer)
9518         *d++ = '\n';
9519     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
9520     if (*peek == '`' || *peek == '\'' || *peek =='"') {
9521         s = peek;
9522         term = *s++;
9523         s = delimcpy(d, e, s, PL_bufend, term, &len);
9524         d += len;
9525         if (s < PL_bufend)
9526             s++;
9527     }
9528     else {
9529         if (*s == '\\')
9530             s++, term = '\'';
9531         else
9532             term = '"';
9533         if (!isALNUM_lazy_if(s,UTF))
9534             deprecate_old("bare << to mean <<\"\"");
9535         for (; isALNUM_lazy_if(s,UTF); s++) {
9536             if (d < e)
9537                 *d++ = *s;
9538         }
9539     }
9540     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
9541         Perl_croak(aTHX_ "Delimiter for here document is too long");
9542     *d++ = '\n';
9543     *d = '\0';
9544     len = d - PL_tokenbuf;
9545 #ifndef PERL_STRICT_CR
9546     d = strchr(s, '\r');
9547     if (d) {
9548         char * const olds = s;
9549         s = d;
9550         while (s < PL_bufend) {
9551             if (*s == '\r') {
9552                 *d++ = '\n';
9553                 if (*++s == '\n')
9554                     s++;
9555             }
9556             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
9557                 *d++ = *s++;
9558                 s++;
9559             }
9560             else
9561                 *d++ = *s++;
9562         }
9563         *d = '\0';
9564         PL_bufend = d;
9565         SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9566         s = olds;
9567     }
9568 #endif
9569     if ( outer || !(found_newline = ninstr(s,PL_bufend,newline,newline+1)) ) {
9570         herewas = newSVpvn(s,PL_bufend-s);
9571     }
9572     else {
9573         s--;
9574         herewas = newSVpvn(s,found_newline-s);
9575     }
9576     s += SvCUR(herewas);
9577
9578     tmpstr = NEWSV(87,79);
9579     sv_upgrade(tmpstr, SVt_PVIV);
9580     if (term == '\'') {
9581         op_type = OP_CONST;
9582         SvIV_set(tmpstr, -1);
9583     }
9584     else if (term == '`') {
9585         op_type = OP_BACKTICK;
9586         SvIV_set(tmpstr, '\\');
9587     }
9588
9589     CLINE;
9590     PL_multi_start = CopLINE(PL_curcop);
9591     PL_multi_open = PL_multi_close = '<';
9592     term = *PL_tokenbuf;
9593     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
9594         char *bufptr = PL_sublex_info.super_bufptr;
9595         char *bufend = PL_sublex_info.super_bufend;
9596         char * const olds = s - SvCUR(herewas);
9597         s = strchr(bufptr, '\n');
9598         if (!s)
9599             s = bufend;
9600         d = s;
9601         while (s < bufend &&
9602           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9603             if (*s++ == '\n')
9604                 CopLINE_inc(PL_curcop);
9605         }
9606         if (s >= bufend) {
9607             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9608             missingterm(PL_tokenbuf);
9609         }
9610         sv_setpvn(herewas,bufptr,d-bufptr+1);
9611         sv_setpvn(tmpstr,d+1,s-d);
9612         s += len - 1;
9613         sv_catpvn(herewas,s,bufend-s);
9614         Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
9615
9616         s = olds;
9617         goto retval;
9618     }
9619     else if (!outer) {
9620         d = s;
9621         while (s < PL_bufend &&
9622           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
9623             if (*s++ == '\n')
9624                 CopLINE_inc(PL_curcop);
9625         }
9626         if (s >= PL_bufend) {
9627             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9628             missingterm(PL_tokenbuf);
9629         }
9630         sv_setpvn(tmpstr,d+1,s-d);
9631         s += len - 1;
9632         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
9633
9634         sv_catpvn(herewas,s,PL_bufend-s);
9635         sv_setsv(PL_linestr,herewas);
9636         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
9637         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9638         PL_last_lop = PL_last_uni = Nullch;
9639     }
9640     else
9641         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
9642     while (s >= PL_bufend) {    /* multiple line string? */
9643         if (!outer ||
9644          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
9645             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
9646             missingterm(PL_tokenbuf);
9647         }
9648         CopLINE_inc(PL_curcop);
9649         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9650         PL_last_lop = PL_last_uni = Nullch;
9651 #ifndef PERL_STRICT_CR
9652         if (PL_bufend - PL_linestart >= 2) {
9653             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
9654                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
9655             {
9656                 PL_bufend[-2] = '\n';
9657                 PL_bufend--;
9658                 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
9659             }
9660             else if (PL_bufend[-1] == '\r')
9661                 PL_bufend[-1] = '\n';
9662         }
9663         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
9664             PL_bufend[-1] = '\n';
9665 #endif
9666         if (PERLDB_LINE && PL_curstash != PL_debstash) {
9667             SV *sv = NEWSV(88,0);
9668
9669             sv_upgrade(sv, SVt_PVMG);
9670             sv_setsv(sv,PL_linestr);
9671             (void)SvIOK_on(sv);
9672             SvIV_set(sv, 0);
9673             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
9674         }
9675         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
9676             STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
9677             *(SvPVX(PL_linestr) + off ) = ' ';
9678             sv_catsv(PL_linestr,herewas);
9679             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9680             s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
9681         }
9682         else {
9683             s = PL_bufend;
9684             sv_catsv(tmpstr,PL_linestr);
9685         }
9686     }
9687     s++;
9688 retval:
9689     PL_multi_end = CopLINE(PL_curcop);
9690     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
9691         SvPV_shrink_to_cur(tmpstr);
9692     }
9693     SvREFCNT_dec(herewas);
9694     if (!IN_BYTES) {
9695         if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
9696             SvUTF8_on(tmpstr);
9697         else if (PL_encoding)
9698             sv_recode_to_utf8(tmpstr, PL_encoding);
9699     }
9700     PL_lex_stuff = tmpstr;
9701     yylval.ival = op_type;
9702     return s;
9703 }
9704
9705 /* scan_inputsymbol
9706    takes: current position in input buffer
9707    returns: new position in input buffer
9708    side-effects: yylval and lex_op are set.
9709
9710    This code handles:
9711
9712    <>           read from ARGV
9713    <FH>         read from filehandle
9714    <pkg::FH>    read from package qualified filehandle
9715    <pkg'FH>     read from package qualified filehandle
9716    <$fh>        read from filehandle in $fh
9717    <*.h>        filename glob
9718
9719 */
9720
9721 STATIC char *
9722 S_scan_inputsymbol(pTHX_ char *start)
9723 {
9724     register char *s = start;           /* current position in buffer */
9725     register char *d;
9726     const char *e;
9727     char *end;
9728     I32 len;
9729
9730     d = PL_tokenbuf;                    /* start of temp holding space */
9731     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
9732     end = strchr(s, '\n');
9733     if (!end)
9734         end = PL_bufend;
9735     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
9736
9737     /* die if we didn't have space for the contents of the <>,
9738        or if it didn't end, or if we see a newline
9739     */
9740
9741     if (len >= sizeof PL_tokenbuf)
9742         Perl_croak(aTHX_ "Excessively long <> operator");
9743     if (s >= end)
9744         Perl_croak(aTHX_ "Unterminated <> operator");
9745
9746     s++;
9747
9748     /* check for <$fh>
9749        Remember, only scalar variables are interpreted as filehandles by
9750        this code.  Anything more complex (e.g., <$fh{$num}>) will be
9751        treated as a glob() call.
9752        This code makes use of the fact that except for the $ at the front,
9753        a scalar variable and a filehandle look the same.
9754     */
9755     if (*d == '$' && d[1]) d++;
9756
9757     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
9758     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
9759         d++;
9760
9761     /* If we've tried to read what we allow filehandles to look like, and
9762        there's still text left, then it must be a glob() and not a getline.
9763        Use scan_str to pull out the stuff between the <> and treat it
9764        as nothing more than a string.
9765     */
9766
9767     if (d - PL_tokenbuf != len) {
9768         yylval.ival = OP_GLOB;
9769         set_csh();
9770         s = scan_str(start,FALSE,FALSE);
9771         if (!s)
9772            Perl_croak(aTHX_ "Glob not terminated");
9773         return s;
9774     }
9775     else {
9776         bool readline_overriden = FALSE;
9777         GV *gv_readline = Nullgv;
9778         GV **gvp;
9779         /* we're in a filehandle read situation */
9780         d = PL_tokenbuf;
9781
9782         /* turn <> into <ARGV> */
9783         if (!len)
9784             Copy("ARGV",d,5,char);
9785
9786         /* Check whether readline() is overriden */
9787         if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
9788                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
9789                 ||
9790                 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
9791                 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
9792                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
9793             readline_overriden = TRUE;
9794
9795         /* if <$fh>, create the ops to turn the variable into a
9796            filehandle
9797         */
9798         if (*d == '$') {
9799             I32 tmp;
9800
9801             /* try to find it in the pad for this block, otherwise find
9802                add symbol table ops
9803             */
9804             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
9805                 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
9806                     HV *stash = PAD_COMPNAME_OURSTASH(tmp);
9807                     HEK *stashname = HvNAME_HEK(stash);
9808                     SV *sym = sv_2mortal(newSVhek(stashname));
9809                     sv_catpvn(sym, "::", 2);
9810                     sv_catpv(sym, d+1);
9811                     d = SvPVX(sym);
9812                     goto intro_sym;
9813                 }
9814                 else {
9815                     OP *o = newOP(OP_PADSV, 0);
9816                     o->op_targ = tmp;
9817                     PL_lex_op = readline_overriden
9818                         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9819                                 append_elem(OP_LIST, o,
9820                                     newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
9821                         : (OP*)newUNOP(OP_READLINE, 0, o);
9822                 }
9823             }
9824             else {
9825                 GV *gv;
9826                 ++d;
9827 intro_sym:
9828                 gv = gv_fetchpv(d,
9829                                 (PL_in_eval
9830                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
9831                                  : GV_ADDMULTI),
9832                                 SVt_PV);
9833                 PL_lex_op = readline_overriden
9834                     ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9835                             append_elem(OP_LIST,
9836                                 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
9837                                 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9838                     : (OP*)newUNOP(OP_READLINE, 0,
9839                             newUNOP(OP_RV2SV, 0,
9840                                 newGVOP(OP_GV, 0, gv)));
9841             }
9842             if (!readline_overriden)
9843                 PL_lex_op->op_flags |= OPf_SPECIAL;
9844             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
9845             yylval.ival = OP_NULL;
9846         }
9847
9848         /* If it's none of the above, it must be a literal filehandle
9849            (<Foo::BAR> or <FOO>) so build a simple readline OP */
9850         else {
9851             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
9852             PL_lex_op = readline_overriden
9853                 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
9854                         append_elem(OP_LIST,
9855                             newGVOP(OP_GV, 0, gv),
9856                             newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
9857                 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
9858             yylval.ival = OP_NULL;
9859         }
9860     }
9861
9862     return s;
9863 }
9864
9865
9866 /* scan_str
9867    takes: start position in buffer
9868           keep_quoted preserve \ on the embedded delimiter(s)
9869           keep_delims preserve the delimiters around the string
9870    returns: position to continue reading from buffer
9871    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
9872         updates the read buffer.
9873
9874    This subroutine pulls a string out of the input.  It is called for:
9875         q               single quotes           q(literal text)
9876         '               single quotes           'literal text'
9877         qq              double quotes           qq(interpolate $here please)
9878         "               double quotes           "interpolate $here please"
9879         qx              backticks               qx(/bin/ls -l)
9880         `               backticks               `/bin/ls -l`
9881         qw              quote words             @EXPORT_OK = qw( func() $spam )
9882         m//             regexp match            m/this/
9883         s///            regexp substitute       s/this/that/
9884         tr///           string transliterate    tr/this/that/
9885         y///            string transliterate    y/this/that/
9886         ($*@)           sub prototypes          sub foo ($)
9887         (stuff)         sub attr parameters     sub foo : attr(stuff)
9888         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
9889         
9890    In most of these cases (all but <>, patterns and transliterate)
9891    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
9892    calls scan_str().  s/// makes yylex() call scan_subst() which calls
9893    scan_str().  tr/// and y/// make yylex() call scan_trans() which
9894    calls scan_str().
9895
9896    It skips whitespace before the string starts, and treats the first
9897    character as the delimiter.  If the delimiter is one of ([{< then
9898    the corresponding "close" character )]}> is used as the closing
9899    delimiter.  It allows quoting of delimiters, and if the string has
9900    balanced delimiters ([{<>}]) it allows nesting.
9901
9902    On success, the SV with the resulting string is put into lex_stuff or,
9903    if that is already non-NULL, into lex_repl. The second case occurs only
9904    when parsing the RHS of the special constructs s/// and tr/// (y///).
9905    For convenience, the terminating delimiter character is stuffed into
9906    SvIVX of the SV.
9907 */
9908
9909 STATIC char *
9910 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
9911 {
9912     SV *sv;                             /* scalar value: string */
9913     char *tmps;                         /* temp string, used for delimiter matching */
9914     register char *s = start;           /* current position in the buffer */
9915     register char term;                 /* terminating character */
9916     register char *to;                  /* current position in the sv's data */
9917     I32 brackets = 1;                   /* bracket nesting level */
9918     bool has_utf8 = FALSE;              /* is there any utf8 content? */
9919     I32 termcode;                       /* terminating char. code */
9920     U8 termstr[UTF8_MAXBYTES];          /* terminating string */
9921     STRLEN termlen;                     /* length of terminating string */
9922     char *last = NULL;                  /* last position for nesting bracket */
9923
9924     /* skip space before the delimiter */
9925     if (isSPACE(*s))
9926         s = skipspace(s);
9927
9928     /* mark where we are, in case we need to report errors */
9929     CLINE;
9930
9931     /* after skipping whitespace, the next character is the terminator */
9932     term = *s;
9933     if (!UTF) {
9934         termcode = termstr[0] = term;
9935         termlen = 1;
9936     }
9937     else {
9938         termcode = utf8_to_uvchr((U8*)s, &termlen);
9939         Copy(s, termstr, termlen, U8);
9940         if (!UTF8_IS_INVARIANT(term))
9941             has_utf8 = TRUE;
9942     }
9943
9944     /* mark where we are */
9945     PL_multi_start = CopLINE(PL_curcop);
9946     PL_multi_open = term;
9947
9948     /* find corresponding closing delimiter */
9949     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
9950         termcode = termstr[0] = term = tmps[5];
9951
9952     PL_multi_close = term;
9953
9954     /* create a new SV to hold the contents.  87 is leak category, I'm
9955        assuming.  79 is the SV's initial length.  What a random number. */
9956     sv = NEWSV(87,79);
9957     sv_upgrade(sv, SVt_PVIV);
9958     SvIV_set(sv, termcode);
9959     (void)SvPOK_only(sv);               /* validate pointer */
9960
9961     /* move past delimiter and try to read a complete string */
9962     if (keep_delims)
9963         sv_catpvn(sv, s, termlen);
9964     s += termlen;
9965     for (;;) {
9966         if (PL_encoding && !UTF) {
9967             bool cont = TRUE;
9968
9969             while (cont) {
9970                 int offset = s - SvPVX_const(PL_linestr);
9971                 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
9972                                            &offset, (char*)termstr, termlen);
9973                 const char *ns = SvPVX_const(PL_linestr) + offset;
9974                 char *svlast = SvEND(sv) - 1;
9975
9976                 for (; s < ns; s++) {
9977                     if (*s == '\n' && !PL_rsfp)
9978                         CopLINE_inc(PL_curcop);
9979                 }
9980                 if (!found)
9981                     goto read_more_line;
9982                 else {
9983                     /* handle quoted delimiters */
9984                     if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
9985                         const char *t;
9986                         for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
9987                             t--;
9988                         if ((svlast-1 - t) % 2) {
9989                             if (!keep_quoted) {
9990                                 *(svlast-1) = term;
9991                                 *svlast = '\0';
9992                                 SvCUR_set(sv, SvCUR(sv) - 1);
9993                             }
9994                             continue;
9995                         }
9996                     }
9997                     if (PL_multi_open == PL_multi_close) {
9998                         cont = FALSE;
9999                     }
10000                     else {
10001                         const char *t;
10002                         char *w;
10003                         if (!last)
10004                             last = SvPVX(sv);
10005                         for (t = w = last; t < svlast; w++, t++) {
10006                             /* At here, all closes are "was quoted" one,
10007                                so we don't check PL_multi_close. */
10008                             if (*t == '\\') {
10009                                 if (!keep_quoted && *(t+1) == PL_multi_open)
10010                                     t++;
10011                                 else
10012                                     *w++ = *t++;
10013                             }
10014                             else if (*t == PL_multi_open)
10015                                 brackets++;
10016
10017                             *w = *t;
10018                         }
10019                         if (w < t) {
10020                             *w++ = term;
10021                             *w = '\0';
10022                             SvCUR_set(sv, w - SvPVX_const(sv));
10023                         }
10024                         last = w;
10025                         if (--brackets <= 0)
10026                             cont = FALSE;
10027                     }
10028                 }
10029             }
10030             if (!keep_delims) {
10031                 SvCUR_set(sv, SvCUR(sv) - 1);
10032                 *SvEND(sv) = '\0';
10033             }
10034             break;
10035         }
10036
10037         /* extend sv if need be */
10038         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
10039         /* set 'to' to the next character in the sv's string */
10040         to = SvPVX(sv)+SvCUR(sv);
10041
10042         /* if open delimiter is the close delimiter read unbridle */
10043         if (PL_multi_open == PL_multi_close) {
10044             for (; s < PL_bufend; s++,to++) {
10045                 /* embedded newlines increment the current line number */
10046                 if (*s == '\n' && !PL_rsfp)
10047                     CopLINE_inc(PL_curcop);
10048                 /* handle quoted delimiters */
10049                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
10050                     if (!keep_quoted && s[1] == term)
10051                         s++;
10052                 /* any other quotes are simply copied straight through */
10053                     else
10054                         *to++ = *s++;
10055                 }
10056                 /* terminate when run out of buffer (the for() condition), or
10057                    have found the terminator */
10058                 else if (*s == term) {
10059                     if (termlen == 1)
10060                         break;
10061                     if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
10062                         break;
10063                 }
10064                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10065                     has_utf8 = TRUE;
10066                 *to = *s;
10067             }
10068         }
10069         
10070         /* if the terminator isn't the same as the start character (e.g.,
10071            matched brackets), we have to allow more in the quoting, and
10072            be prepared for nested brackets.
10073         */
10074         else {
10075             /* read until we run out of string, or we find the terminator */
10076             for (; s < PL_bufend; s++,to++) {
10077                 /* embedded newlines increment the line count */
10078                 if (*s == '\n' && !PL_rsfp)
10079                     CopLINE_inc(PL_curcop);
10080                 /* backslashes can escape the open or closing characters */
10081                 if (*s == '\\' && s+1 < PL_bufend) {
10082                     if (!keep_quoted &&
10083                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
10084                         s++;
10085                     else
10086                         *to++ = *s++;
10087                 }
10088                 /* allow nested opens and closes */
10089                 else if (*s == PL_multi_close && --brackets <= 0)
10090                     break;
10091                 else if (*s == PL_multi_open)
10092                     brackets++;
10093                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
10094                     has_utf8 = TRUE;
10095                 *to = *s;
10096             }
10097         }
10098         /* terminate the copied string and update the sv's end-of-string */
10099         *to = '\0';
10100         SvCUR_set(sv, to - SvPVX_const(sv));
10101
10102         /*
10103          * this next chunk reads more into the buffer if we're not done yet
10104          */
10105
10106         if (s < PL_bufend)
10107             break;              /* handle case where we are done yet :-) */
10108
10109 #ifndef PERL_STRICT_CR
10110         if (to - SvPVX_const(sv) >= 2) {
10111             if ((to[-2] == '\r' && to[-1] == '\n') ||
10112                 (to[-2] == '\n' && to[-1] == '\r'))
10113             {
10114                 to[-2] = '\n';
10115                 to--;
10116                 SvCUR_set(sv, to - SvPVX_const(sv));
10117             }
10118             else if (to[-1] == '\r')
10119                 to[-1] = '\n';
10120         }
10121         else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
10122             to[-1] = '\n';
10123 #endif
10124         
10125      read_more_line:
10126         /* if we're out of file, or a read fails, bail and reset the current
10127            line marker so we can report where the unterminated string began
10128         */
10129         if (!PL_rsfp ||
10130          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
10131             sv_free(sv);
10132             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
10133             return Nullch;
10134         }
10135         /* we read a line, so increment our line counter */
10136         CopLINE_inc(PL_curcop);
10137
10138         /* update debugger info */
10139         if (PERLDB_LINE && PL_curstash != PL_debstash) {
10140             SV *sv = NEWSV(88,0);
10141
10142             sv_upgrade(sv, SVt_PVMG);
10143             sv_setsv(sv,PL_linestr);
10144             (void)SvIOK_on(sv);
10145             SvIV_set(sv, 0);
10146             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
10147         }
10148
10149         /* having changed the buffer, we must update PL_bufend */
10150         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10151         PL_last_lop = PL_last_uni = Nullch;
10152     }
10153
10154     /* at this point, we have successfully read the delimited string */
10155
10156     if (!PL_encoding || UTF) {
10157         if (keep_delims)
10158             sv_catpvn(sv, s, termlen);
10159         s += termlen;
10160     }
10161     if (has_utf8 || PL_encoding)
10162         SvUTF8_on(sv);
10163
10164     PL_multi_end = CopLINE(PL_curcop);
10165
10166     /* if we allocated too much space, give some back */
10167     if (SvCUR(sv) + 5 < SvLEN(sv)) {
10168         SvLEN_set(sv, SvCUR(sv) + 1);
10169         SvPV_renew(sv, SvLEN(sv));
10170     }
10171
10172     /* decide whether this is the first or second quoted string we've read
10173        for this op
10174     */
10175
10176     if (PL_lex_stuff)
10177         PL_lex_repl = sv;
10178     else
10179         PL_lex_stuff = sv;
10180     return s;
10181 }
10182
10183 /*
10184   scan_num
10185   takes: pointer to position in buffer
10186   returns: pointer to new position in buffer
10187   side-effects: builds ops for the constant in yylval.op
10188
10189   Read a number in any of the formats that Perl accepts:
10190
10191   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
10192   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
10193   0b[01](_?[01])*
10194   0[0-7](_?[0-7])*
10195   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
10196
10197   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
10198   thing it reads.
10199
10200   If it reads a number without a decimal point or an exponent, it will
10201   try converting the number to an integer and see if it can do so
10202   without loss of precision.
10203 */
10204
10205 char *
10206 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
10207 {
10208     register const char *s = start;     /* current position in buffer */
10209     register char *d;                   /* destination in temp buffer */
10210     register char *e;                   /* end of temp buffer */
10211     NV nv;                              /* number read, as a double */
10212     SV *sv = Nullsv;                    /* place to put the converted number */
10213     bool floatit;                       /* boolean: int or float? */
10214     const char *lastub = 0;             /* position of last underbar */
10215     static char const number_too_long[] = "Number too long";
10216
10217     /* We use the first character to decide what type of number this is */
10218
10219     switch (*s) {
10220     default:
10221       Perl_croak(aTHX_ "panic: scan_num");
10222
10223     /* if it starts with a 0, it could be an octal number, a decimal in
10224        0.13 disguise, or a hexadecimal number, or a binary number. */
10225     case '0':
10226         {
10227           /* variables:
10228              u          holds the "number so far"
10229              shift      the power of 2 of the base
10230                         (hex == 4, octal == 3, binary == 1)
10231              overflowed was the number more than we can hold?
10232
10233              Shift is used when we add a digit.  It also serves as an "are
10234              we in octal/hex/binary?" indicator to disallow hex characters
10235              when in octal mode.
10236            */
10237             NV n = 0.0;
10238             UV u = 0;
10239             I32 shift;
10240             bool overflowed = FALSE;
10241             bool just_zero  = TRUE;     /* just plain 0 or binary number? */
10242             static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
10243             static const char* const bases[5] =
10244               { "", "binary", "", "octal", "hexadecimal" };
10245             static const char* const Bases[5] =
10246               { "", "Binary", "", "Octal", "Hexadecimal" };
10247             static const char* const maxima[5] =
10248               { "",
10249                 "0b11111111111111111111111111111111",
10250                 "",
10251                 "037777777777",
10252                 "0xffffffff" };
10253             const char *base, *Base, *max;
10254
10255             /* check for hex */
10256             if (s[1] == 'x') {
10257                 shift = 4;
10258                 s += 2;
10259                 just_zero = FALSE;
10260             } else if (s[1] == 'b') {
10261                 shift = 1;
10262                 s += 2;
10263                 just_zero = FALSE;
10264             }
10265             /* check for a decimal in disguise */
10266             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
10267                 goto decimal;
10268             /* so it must be octal */
10269             else {
10270                 shift = 3;
10271                 s++;
10272             }
10273
10274             if (*s == '_') {
10275                if (ckWARN(WARN_SYNTAX))
10276                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10277                                "Misplaced _ in number");
10278                lastub = s++;
10279             }
10280
10281             base = bases[shift];
10282             Base = Bases[shift];
10283             max  = maxima[shift];
10284
10285             /* read the rest of the number */
10286             for (;;) {
10287                 /* x is used in the overflow test,
10288                    b is the digit we're adding on. */
10289                 UV x, b;
10290
10291                 switch (*s) {
10292
10293                 /* if we don't mention it, we're done */
10294                 default:
10295                     goto out;
10296
10297                 /* _ are ignored -- but warned about if consecutive */
10298                 case '_':
10299                     if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10300                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10301                                     "Misplaced _ in number");
10302                     lastub = s++;
10303                     break;
10304
10305                 /* 8 and 9 are not octal */
10306                 case '8': case '9':
10307                     if (shift == 3)
10308                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
10309                     /* FALL THROUGH */
10310
10311                 /* octal digits */
10312                 case '2': case '3': case '4':
10313                 case '5': case '6': case '7':
10314                     if (shift == 1)
10315                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
10316                     /* FALL THROUGH */
10317
10318                 case '0': case '1':
10319                     b = *s++ & 15;              /* ASCII digit -> value of digit */
10320                     goto digit;
10321
10322                 /* hex digits */
10323                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
10324                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
10325                     /* make sure they said 0x */
10326                     if (shift != 4)
10327                         goto out;
10328                     b = (*s++ & 7) + 9;
10329
10330                     /* Prepare to put the digit we have onto the end
10331                        of the number so far.  We check for overflows.
10332                     */
10333
10334                   digit:
10335                     just_zero = FALSE;
10336                     if (!overflowed) {
10337                         x = u << shift; /* make room for the digit */
10338
10339                         if ((x >> shift) != u
10340                             && !(PL_hints & HINT_NEW_BINARY)) {
10341                             overflowed = TRUE;
10342                             n = (NV) u;
10343                             if (ckWARN_d(WARN_OVERFLOW))
10344                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
10345                                             "Integer overflow in %s number",
10346                                             base);
10347                         } else
10348                             u = x | b;          /* add the digit to the end */
10349                     }
10350                     if (overflowed) {
10351                         n *= nvshift[shift];
10352                         /* If an NV has not enough bits in its
10353                          * mantissa to represent an UV this summing of
10354                          * small low-order numbers is a waste of time
10355                          * (because the NV cannot preserve the
10356                          * low-order bits anyway): we could just
10357                          * remember when did we overflow and in the
10358                          * end just multiply n by the right
10359                          * amount. */
10360                         n += (NV) b;
10361                     }
10362                     break;
10363                 }
10364             }
10365
10366           /* if we get here, we had success: make a scalar value from
10367              the number.
10368           */
10369           out:
10370
10371             /* final misplaced underbar check */
10372             if (s[-1] == '_') {
10373                 if (ckWARN(WARN_SYNTAX))
10374                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10375             }
10376
10377             sv = NEWSV(92,0);
10378             if (overflowed) {
10379                 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
10380                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10381                                 "%s number > %s non-portable",
10382                                 Base, max);
10383                 sv_setnv(sv, n);
10384             }
10385             else {
10386 #if UVSIZE > 4
10387                 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
10388                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
10389                                 "%s number > %s non-portable",
10390                                 Base, max);
10391 #endif
10392                 sv_setuv(sv, u);
10393             }
10394             if (just_zero && (PL_hints & HINT_NEW_INTEGER))
10395                 sv = new_constant(start, s - start, "integer",
10396                                   sv, Nullsv, NULL);
10397             else if (PL_hints & HINT_NEW_BINARY)
10398                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
10399         }
10400         break;
10401
10402     /*
10403       handle decimal numbers.
10404       we're also sent here when we read a 0 as the first digit
10405     */
10406     case '1': case '2': case '3': case '4': case '5':
10407     case '6': case '7': case '8': case '9': case '.':
10408       decimal:
10409         d = PL_tokenbuf;
10410         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
10411         floatit = FALSE;
10412
10413         /* read next group of digits and _ and copy into d */
10414         while (isDIGIT(*s) || *s == '_') {
10415             /* skip underscores, checking for misplaced ones
10416                if -w is on
10417             */
10418             if (*s == '_') {
10419                 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10420                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10421                                 "Misplaced _ in number");
10422                 lastub = s++;
10423             }
10424             else {
10425                 /* check for end of fixed-length buffer */
10426                 if (d >= e)
10427                     Perl_croak(aTHX_ number_too_long);
10428                 /* if we're ok, copy the character */
10429                 *d++ = *s++;
10430             }
10431         }
10432
10433         /* final misplaced underbar check */
10434         if (lastub && s == lastub + 1) {
10435             if (ckWARN(WARN_SYNTAX))
10436                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
10437         }
10438
10439         /* read a decimal portion if there is one.  avoid
10440            3..5 being interpreted as the number 3. followed
10441            by .5
10442         */
10443         if (*s == '.' && s[1] != '.') {
10444             floatit = TRUE;
10445             *d++ = *s++;
10446
10447             if (*s == '_') {
10448                 if (ckWARN(WARN_SYNTAX))
10449                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10450                                 "Misplaced _ in number");
10451                 lastub = s;
10452             }
10453
10454             /* copy, ignoring underbars, until we run out of digits.
10455             */
10456             for (; isDIGIT(*s) || *s == '_'; s++) {
10457                 /* fixed length buffer check */
10458                 if (d >= e)
10459                     Perl_croak(aTHX_ number_too_long);
10460                 if (*s == '_') {
10461                    if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
10462                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10463                                    "Misplaced _ in number");
10464                    lastub = s;
10465                 }
10466                 else
10467                     *d++ = *s;
10468             }
10469             /* fractional part ending in underbar? */
10470             if (s[-1] == '_') {
10471                 if (ckWARN(WARN_SYNTAX))
10472                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10473                                 "Misplaced _ in number");
10474             }
10475             if (*s == '.' && isDIGIT(s[1])) {
10476                 /* oops, it's really a v-string, but without the "v" */
10477                 s = start;
10478                 goto vstring;
10479             }
10480         }
10481
10482         /* read exponent part, if present */
10483         if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
10484             floatit = TRUE;
10485             s++;
10486
10487             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
10488             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
10489
10490             /* stray preinitial _ */
10491             if (*s == '_') {
10492                 if (ckWARN(WARN_SYNTAX))
10493                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10494                                 "Misplaced _ in number");
10495                 lastub = s++;
10496             }
10497
10498             /* allow positive or negative exponent */
10499             if (*s == '+' || *s == '-')
10500                 *d++ = *s++;
10501
10502             /* stray initial _ */
10503             if (*s == '_') {
10504                 if (ckWARN(WARN_SYNTAX))
10505                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10506                                 "Misplaced _ in number");
10507                 lastub = s++;
10508             }
10509
10510             /* read digits of exponent */
10511             while (isDIGIT(*s) || *s == '_') {
10512                 if (isDIGIT(*s)) {
10513                     if (d >= e)
10514                         Perl_croak(aTHX_ number_too_long);
10515                     *d++ = *s++;
10516                 }
10517                 else {
10518                    if (((lastub && s == lastub + 1) ||
10519                         (!isDIGIT(s[1]) && s[1] != '_'))
10520                     && ckWARN(WARN_SYNTAX))
10521                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10522                                    "Misplaced _ in number");
10523                    lastub = s++;
10524                 }
10525             }
10526         }
10527
10528
10529         /* make an sv from the string */
10530         sv = NEWSV(92,0);
10531
10532         /*
10533            We try to do an integer conversion first if no characters
10534            indicating "float" have been found.
10535          */
10536
10537         if (!floatit) {
10538             UV uv;
10539             int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
10540
10541             if (flags == IS_NUMBER_IN_UV) {
10542               if (uv <= IV_MAX)
10543                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
10544               else
10545                 sv_setuv(sv, uv);
10546             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
10547               if (uv <= (UV) IV_MIN)
10548                 sv_setiv(sv, -(IV)uv);
10549               else
10550                 floatit = TRUE;
10551             } else
10552               floatit = TRUE;
10553         }
10554         if (floatit) {
10555             /* terminate the string */
10556             *d = '\0';
10557             nv = Atof(PL_tokenbuf);
10558             sv_setnv(sv, nv);
10559         }
10560
10561         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
10562                        (PL_hints & HINT_NEW_INTEGER) )
10563             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
10564                               (floatit ? "float" : "integer"),
10565                               sv, Nullsv, NULL);
10566         break;
10567
10568     /* if it starts with a v, it could be a v-string */
10569     case 'v':
10570 vstring:
10571                 sv = NEWSV(92,5); /* preallocate storage space */
10572                 s = scan_vstring(s,sv);
10573         break;
10574     }
10575
10576     /* make the op for the constant and return */
10577
10578     if (sv)
10579         lvalp->opval = newSVOP(OP_CONST, 0, sv);
10580     else
10581         lvalp->opval = Nullop;
10582
10583     return (char *)s;
10584 }
10585
10586 STATIC char *
10587 S_scan_formline(pTHX_ register char *s)
10588 {
10589     register char *eol;
10590     register char *t;
10591     SV *stuff = newSVpvn("",0);
10592     bool needargs = FALSE;
10593     bool eofmt = FALSE;
10594
10595     while (!needargs) {
10596         if (*s == '.') {
10597 #ifdef PERL_STRICT_CR
10598             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
10599 #else
10600             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
10601 #endif
10602             if (*t == '\n' || t == PL_bufend) {
10603                 eofmt = TRUE;
10604                 break;
10605             }
10606         }
10607         if (PL_in_eval && !PL_rsfp) {
10608             eol = (char *) memchr(s,'\n',PL_bufend-s);
10609             if (!eol++)
10610                 eol = PL_bufend;
10611         }
10612         else
10613             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
10614         if (*s != '#') {
10615             for (t = s; t < eol; t++) {
10616                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
10617                     needargs = FALSE;
10618                     goto enough;        /* ~~ must be first line in formline */
10619                 }
10620                 if (*t == '@' || *t == '^')
10621                     needargs = TRUE;
10622             }
10623             if (eol > s) {
10624                 sv_catpvn(stuff, s, eol-s);
10625 #ifndef PERL_STRICT_CR
10626                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
10627                     char *end = SvPVX(stuff) + SvCUR(stuff);
10628                     end[-2] = '\n';
10629                     end[-1] = '\0';
10630                     SvCUR_set(stuff, SvCUR(stuff) - 1);
10631                 }
10632 #endif
10633             }
10634             else
10635               break;
10636         }
10637         s = (char*)eol;
10638         if (PL_rsfp) {
10639             s = filter_gets(PL_linestr, PL_rsfp, 0);
10640             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
10641             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
10642             PL_last_lop = PL_last_uni = Nullch;
10643             if (!s) {
10644                 s = PL_bufptr;
10645                 break;
10646             }
10647         }
10648         incline(s);
10649     }
10650   enough:
10651     if (SvCUR(stuff)) {
10652         PL_expect = XTERM;
10653         if (needargs) {
10654             PL_lex_state = LEX_NORMAL;
10655             PL_nextval[PL_nexttoke].ival = 0;
10656             force_next(',');
10657         }
10658         else
10659             PL_lex_state = LEX_FORMLINE;
10660         if (!IN_BYTES) {
10661             if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
10662                 SvUTF8_on(stuff);
10663             else if (PL_encoding)
10664                 sv_recode_to_utf8(stuff, PL_encoding);
10665         }
10666         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
10667         force_next(THING);
10668         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
10669         force_next(LSTOP);
10670     }
10671     else {
10672         SvREFCNT_dec(stuff);
10673         if (eofmt)
10674             PL_lex_formbrack = 0;
10675         PL_bufptr = s;
10676     }
10677     return s;
10678 }
10679
10680 STATIC void
10681 S_set_csh(pTHX)
10682 {
10683 #ifdef CSH
10684     if (!PL_cshlen)
10685         PL_cshlen = strlen(PL_cshname);
10686 #endif
10687 }
10688
10689 I32
10690 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
10691 {
10692     const I32 oldsavestack_ix = PL_savestack_ix;
10693     CV* outsidecv = PL_compcv;
10694
10695     if (PL_compcv) {
10696         assert(SvTYPE(PL_compcv) == SVt_PVCV);
10697     }
10698     SAVEI32(PL_subline);
10699     save_item(PL_subname);
10700     SAVESPTR(PL_compcv);
10701
10702     PL_compcv = (CV*)NEWSV(1104,0);
10703     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
10704     CvFLAGS(PL_compcv) |= flags;
10705
10706     PL_subline = CopLINE(PL_curcop);
10707     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
10708     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
10709     CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
10710
10711     return oldsavestack_ix;
10712 }
10713
10714 #ifdef __SC__
10715 #pragma segment Perl_yylex
10716 #endif
10717 int
10718 Perl_yywarn(pTHX_ const char *s)
10719 {
10720     PL_in_eval |= EVAL_WARNONLY;
10721     yyerror(s);
10722     PL_in_eval &= ~EVAL_WARNONLY;
10723     return 0;
10724 }
10725
10726 int
10727 Perl_yyerror(pTHX_ const char *s)
10728 {
10729     const char *where = NULL;
10730     const char *context = NULL;
10731     int contlen = -1;
10732     SV *msg;
10733
10734     if (!yychar || (yychar == ';' && !PL_rsfp))
10735         where = "at EOF";
10736     else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
10737       PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
10738       PL_oldbufptr != PL_bufptr) {
10739         /*
10740                 Only for NetWare:
10741                 The code below is removed for NetWare because it abends/crashes on NetWare
10742                 when the script has error such as not having the closing quotes like:
10743                     if ($var eq "value)
10744                 Checking of white spaces is anyway done in NetWare code.
10745         */
10746 #ifndef NETWARE
10747         while (isSPACE(*PL_oldoldbufptr))
10748             PL_oldoldbufptr++;
10749 #endif
10750         context = PL_oldoldbufptr;
10751         contlen = PL_bufptr - PL_oldoldbufptr;
10752     }
10753     else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
10754       PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
10755         /*
10756                 Only for NetWare:
10757                 The code below is removed for NetWare because it abends/crashes on NetWare
10758                 when the script has error such as not having the closing quotes like:
10759                     if ($var eq "value)
10760                 Checking of white spaces is anyway done in NetWare code.
10761         */
10762 #ifndef NETWARE
10763         while (isSPACE(*PL_oldbufptr))
10764             PL_oldbufptr++;
10765 #endif
10766         context = PL_oldbufptr;
10767         contlen = PL_bufptr - PL_oldbufptr;
10768     }
10769     else if (yychar > 255)
10770         where = "next token ???";
10771     else if (yychar == -2) { /* YYEMPTY */
10772         if (PL_lex_state == LEX_NORMAL ||
10773            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
10774             where = "at end of line";
10775         else if (PL_lex_inpat)
10776             where = "within pattern";
10777         else
10778             where = "within string";
10779     }
10780     else {
10781         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
10782         if (yychar < 32)
10783             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
10784         else if (isPRINT_LC(yychar))
10785             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
10786         else
10787             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
10788         where = SvPVX_const(where_sv);
10789     }
10790     msg = sv_2mortal(newSVpv(s, 0));
10791     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
10792         OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
10793     if (context)
10794         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
10795     else
10796         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
10797     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
10798         Perl_sv_catpvf(aTHX_ msg,
10799         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
10800                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
10801         PL_multi_end = 0;
10802     }
10803     if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
10804         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
10805     else
10806         qerror(msg);
10807     if (PL_error_count >= 10) {
10808         if (PL_in_eval && SvCUR(ERRSV))
10809             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
10810             ERRSV, OutCopFILE(PL_curcop));
10811         else
10812             Perl_croak(aTHX_ "%s has too many errors.\n",
10813             OutCopFILE(PL_curcop));
10814     }
10815     PL_in_my = 0;
10816     PL_in_my_stash = Nullhv;
10817     return 0;
10818 }
10819 #ifdef __SC__
10820 #pragma segment Main
10821 #endif
10822
10823 STATIC char*
10824 S_swallow_bom(pTHX_ U8 *s)
10825 {
10826     const STRLEN slen = SvCUR(PL_linestr);
10827     switch (s[0]) {
10828     case 0xFF:
10829         if (s[1] == 0xFE) {
10830             /* UTF-16 little-endian? (or UTF32-LE?) */
10831             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
10832                 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
10833 #ifndef PERL_NO_UTF16_FILTER
10834             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
10835             s += 2;
10836         utf16le:
10837             if (PL_bufend > (char*)s) {
10838                 U8 *news;
10839                 I32 newlen;
10840
10841                 filter_add(utf16rev_textfilter, NULL);
10842                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10843                 utf16_to_utf8_reversed(s, news,
10844                                        PL_bufend - (char*)s - 1,
10845                                        &newlen);
10846                 sv_setpvn(PL_linestr, (const char*)news, newlen);
10847                 Safefree(news);
10848                 SvUTF8_on(PL_linestr);
10849                 s = (U8*)SvPVX(PL_linestr);
10850                 PL_bufend = SvPVX(PL_linestr) + newlen;
10851             }
10852 #else
10853             Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
10854 #endif
10855         }
10856         break;
10857     case 0xFE:
10858         if (s[1] == 0xFF) {   /* UTF-16 big-endian? */
10859 #ifndef PERL_NO_UTF16_FILTER
10860             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
10861             s += 2;
10862         utf16be:
10863             if (PL_bufend > (char *)s) {
10864                 U8 *news;
10865                 I32 newlen;
10866
10867                 filter_add(utf16_textfilter, NULL);
10868                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
10869                 utf16_to_utf8(s, news,
10870                               PL_bufend - (char*)s,
10871                               &newlen);
10872                 sv_setpvn(PL_linestr, (const char*)news, newlen);
10873                 Safefree(news);
10874                 SvUTF8_on(PL_linestr);
10875                 s = (U8*)SvPVX(PL_linestr);
10876                 PL_bufend = SvPVX(PL_linestr) + newlen;
10877             }
10878 #else
10879             Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
10880 #endif
10881         }
10882         break;
10883     case 0xEF:
10884         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
10885             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
10886             s += 3;                      /* UTF-8 */
10887         }
10888         break;
10889     case 0:
10890         if (slen > 3) {
10891              if (s[1] == 0) {
10892                   if (s[2] == 0xFE && s[3] == 0xFF) {
10893                        /* UTF-32 big-endian */
10894                        Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
10895                   }
10896              }
10897              else if (s[2] == 0 && s[3] != 0) {
10898                   /* Leading bytes
10899                    * 00 xx 00 xx
10900                    * are a good indicator of UTF-16BE. */
10901                   if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
10902                   goto utf16be;
10903              }
10904         }
10905     default:
10906          if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
10907                   /* Leading bytes
10908                    * xx 00 xx 00
10909                    * are a good indicator of UTF-16LE. */
10910               if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
10911               goto utf16le;
10912          }
10913     }
10914     return (char*)s;
10915 }
10916
10917 /*
10918  * restore_rsfp
10919  * Restore a source filter.
10920  */
10921
10922 static void
10923 restore_rsfp(pTHX_ void *f)
10924 {
10925     PerlIO *fp = (PerlIO*)f;
10926
10927     if (PL_rsfp == PerlIO_stdin())
10928         PerlIO_clearerr(PL_rsfp);
10929     else if (PL_rsfp && (PL_rsfp != fp))
10930         PerlIO_close(PL_rsfp);
10931     PL_rsfp = fp;
10932 }
10933
10934 #ifndef PERL_NO_UTF16_FILTER
10935 static I32
10936 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10937 {
10938     const STRLEN old = SvCUR(sv);
10939     const I32 count = FILTER_READ(idx+1, sv, maxlen);
10940     DEBUG_P(PerlIO_printf(Perl_debug_log,
10941                           "utf16_textfilter(%p): %d %d (%d)\n",
10942                           utf16_textfilter, idx, maxlen, (int) count));
10943     if (count) {
10944         U8* tmps;
10945         I32 newlen;
10946         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10947         Copy(SvPVX_const(sv), tmps, old, char);
10948         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10949                       SvCUR(sv) - old, &newlen);
10950         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10951     }
10952     DEBUG_P({sv_dump(sv);});
10953     return SvCUR(sv);
10954 }
10955
10956 static I32
10957 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
10958 {
10959     const STRLEN old = SvCUR(sv);
10960     const I32 count = FILTER_READ(idx+1, sv, maxlen);
10961     DEBUG_P(PerlIO_printf(Perl_debug_log,
10962                           "utf16rev_textfilter(%p): %d %d (%d)\n",
10963                           utf16rev_textfilter, idx, maxlen, (int) count));
10964     if (count) {
10965         U8* tmps;
10966         I32 newlen;
10967         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
10968         Copy(SvPVX_const(sv), tmps, old, char);
10969         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
10970                       SvCUR(sv) - old, &newlen);
10971         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
10972     }
10973     DEBUG_P({ sv_dump(sv); });
10974     return count;
10975 }
10976 #endif
10977
10978 /*
10979 Returns a pointer to the next character after the parsed
10980 vstring, as well as updating the passed in sv.
10981
10982 Function must be called like
10983
10984         sv = NEWSV(92,5);
10985         s = scan_vstring(s,sv);
10986
10987 The sv should already be large enough to store the vstring
10988 passed in, for performance reasons.
10989
10990 */
10991
10992 char *
10993 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
10994 {
10995     const char *pos = s;
10996     const char *start = s;
10997     if (*pos == 'v') pos++;  /* get past 'v' */
10998     while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
10999         pos++;
11000     if ( *pos != '.') {
11001         /* this may not be a v-string if followed by => */
11002         const char *next = pos;
11003         while (next < PL_bufend && isSPACE(*next))
11004             ++next;
11005         if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
11006             /* return string not v-string */
11007             sv_setpvn(sv,(char *)s,pos-s);
11008             return (char *)pos;
11009         }
11010     }
11011
11012     if (!isALPHA(*pos)) {
11013         UV rev;
11014         U8 tmpbuf[UTF8_MAXBYTES+1];
11015         U8 *tmpend;
11016
11017         if (*s == 'v') s++;  /* get past 'v' */
11018
11019         sv_setpvn(sv, "", 0);
11020
11021         for (;;) {
11022             rev = 0;
11023             {
11024                 /* this is atoi() that tolerates underscores */
11025                 const char *end = pos;
11026                 UV mult = 1;
11027                 while (--end >= s) {
11028                     UV orev;
11029                     if (*end == '_')
11030                         continue;
11031                     orev = rev;
11032                     rev += (*end - '0') * mult;
11033                     mult *= 10;
11034                     if (orev > rev && ckWARN_d(WARN_OVERFLOW))
11035                         Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11036                                     "Integer overflow in decimal number");
11037                 }
11038             }
11039 #ifdef EBCDIC
11040             if (rev > 0x7FFFFFFF)
11041                  Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
11042 #endif
11043             /* Append native character for the rev point */
11044             tmpend = uvchr_to_utf8(tmpbuf, rev);
11045             sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
11046             if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
11047                  SvUTF8_on(sv);
11048             if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
11049                  s = ++pos;
11050             else {
11051                  s = pos;
11052                  break;
11053             }
11054             while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
11055                  pos++;
11056         }
11057         SvPOK_on(sv);
11058         sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
11059         SvRMAGICAL_on(sv);
11060     }
11061     return (char *)s;
11062 }
11063
11064 /*
11065  * Local variables:
11066  * c-indentation-style: bsd
11067  * c-basic-offset: 4
11068  * indent-tabs-mode: t
11069  * End:
11070  *
11071  * ex: set ts=8 sts=4 sw=4 noet:
11072  */