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