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