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