Upgrade to Tie::File 0.20.
[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_ packWARN(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_ packWARN(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_ packWARN(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_ packWARN(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                 /* Incest with pod. */
2574                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2575                     sv_setpv(PL_linestr, "");
2576                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2577                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2578                     PL_last_lop = PL_last_uni = Nullch;
2579                     PL_doextract = FALSE;
2580                 }
2581             }
2582             incline(s);
2583         } while (PL_doextract);
2584         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2585         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2586             SV *sv = NEWSV(85,0);
2587
2588             sv_upgrade(sv, SVt_PVMG);
2589             sv_setsv(sv,PL_linestr);
2590             (void)SvIOK_on(sv);
2591             SvIVX(sv) = 0;
2592             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2593         }
2594         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2595         PL_last_lop = PL_last_uni = Nullch;
2596         if (CopLINE(PL_curcop) == 1) {
2597             while (s < PL_bufend && isSPACE(*s))
2598                 s++;
2599             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2600                 s++;
2601             d = Nullch;
2602             if (!PL_in_eval) {
2603                 if (*s == '#' && *(s+1) == '!')
2604                     d = s + 2;
2605 #ifdef ALTERNATE_SHEBANG
2606                 else {
2607                     static char as[] = ALTERNATE_SHEBANG;
2608                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2609                         d = s + (sizeof(as) - 1);
2610                 }
2611 #endif /* ALTERNATE_SHEBANG */
2612             }
2613             if (d) {
2614                 char *ipath;
2615                 char *ipathend;
2616
2617                 while (isSPACE(*d))
2618                     d++;
2619                 ipath = d;
2620                 while (*d && !isSPACE(*d))
2621                     d++;
2622                 ipathend = d;
2623
2624 #ifdef ARG_ZERO_IS_SCRIPT
2625                 if (ipathend > ipath) {
2626                     /*
2627                      * HP-UX (at least) sets argv[0] to the script name,
2628                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2629                      * at least, set argv[0] to the basename of the Perl
2630                      * interpreter. So, having found "#!", we'll set it right.
2631                      */
2632                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2633                     assert(SvPOK(x) || SvGMAGICAL(x));
2634                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2635                         sv_setpvn(x, ipath, ipathend - ipath);
2636                         SvSETMAGIC(x);
2637                     }
2638                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2639                 }
2640 #endif /* ARG_ZERO_IS_SCRIPT */
2641
2642                 /*
2643                  * Look for options.
2644                  */
2645                 d = instr(s,"perl -");
2646                 if (!d) {
2647                     d = instr(s,"perl");
2648 #if defined(DOSISH)
2649                     /* avoid getting into infinite loops when shebang
2650                      * line contains "Perl" rather than "perl" */
2651                     if (!d) {
2652                         for (d = ipathend-4; d >= ipath; --d) {
2653                             if ((*d == 'p' || *d == 'P')
2654                                 && !ibcmp(d, "perl", 4))
2655                             {
2656                                 break;
2657                             }
2658                         }
2659                         if (d < ipath)
2660                             d = Nullch;
2661                     }
2662 #endif
2663                 }
2664 #ifdef ALTERNATE_SHEBANG
2665                 /*
2666                  * If the ALTERNATE_SHEBANG on this system starts with a
2667                  * character that can be part of a Perl expression, then if
2668                  * we see it but not "perl", we're probably looking at the
2669                  * start of Perl code, not a request to hand off to some
2670                  * other interpreter.  Similarly, if "perl" is there, but
2671                  * not in the first 'word' of the line, we assume the line
2672                  * contains the start of the Perl program.
2673                  */
2674                 if (d && *s != '#') {
2675                     char *c = ipath;
2676                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2677                         c++;
2678                     if (c < d)
2679                         d = Nullch;     /* "perl" not in first word; ignore */
2680                     else
2681                         *s = '#';       /* Don't try to parse shebang line */
2682                 }
2683 #endif /* ALTERNATE_SHEBANG */
2684 #ifndef MACOS_TRADITIONAL
2685                 if (!d &&
2686                     *s == '#' &&
2687                     ipathend > ipath &&
2688                     !PL_minus_c &&
2689                     !instr(s,"indir") &&
2690                     instr(PL_origargv[0],"perl"))
2691                 {
2692                     char **newargv;
2693
2694                     *ipathend = '\0';
2695                     s = ipathend + 1;
2696                     while (s < PL_bufend && isSPACE(*s))
2697                         s++;
2698                     if (s < PL_bufend) {
2699                         Newz(899,newargv,PL_origargc+3,char*);
2700                         newargv[1] = s;
2701                         while (s < PL_bufend && !isSPACE(*s))
2702                             s++;
2703                         *s = '\0';
2704                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2705                     }
2706                     else
2707                         newargv = PL_origargv;
2708                     newargv[0] = ipath;
2709                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2710                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2711                 }
2712 #endif
2713                 if (d) {
2714                     U32 oldpdb = PL_perldb;
2715                     bool oldn = PL_minus_n;
2716                     bool oldp = PL_minus_p;
2717
2718                     while (*d && !isSPACE(*d)) d++;
2719                     while (SPACE_OR_TAB(*d)) d++;
2720
2721                     if (*d++ == '-') {
2722                         bool switches_done = PL_doswitches;
2723                         do {
2724                             if (*d == 'M' || *d == 'm') {
2725                                 char *m = d;
2726                                 while (*d && !isSPACE(*d)) d++;
2727                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2728                                       (int)(d - m), m);
2729                             }
2730                             d = moreswitches(d);
2731                         } while (d);
2732                         if ((PERLDB_LINE && !oldpdb) ||
2733                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2734                               /* if we have already added "LINE: while (<>) {",
2735                                  we must not do it again */
2736                         {
2737                             sv_setpv(PL_linestr, "");
2738                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2739                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2740                             PL_last_lop = PL_last_uni = Nullch;
2741                             PL_preambled = FALSE;
2742                             if (PERLDB_LINE)
2743                                 (void)gv_fetchfile(PL_origfilename);
2744                             goto retry;
2745                         }
2746                         if (PL_doswitches && !switches_done) {
2747                             int argc = PL_origargc;
2748                             char **argv = PL_origargv;
2749                             do {
2750                                 argc--,argv++;
2751                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2752                             init_argv_symbols(argc,argv);
2753                         }
2754                     }
2755                 }
2756             }
2757         }
2758         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2759             PL_bufptr = s;
2760             PL_lex_state = LEX_FORMLINE;
2761             return yylex();
2762         }
2763         goto retry;
2764     case '\r':
2765 #ifdef PERL_STRICT_CR
2766         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2767         Perl_croak(aTHX_
2768       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2769 #endif
2770     case ' ': case '\t': case '\f': case 013:
2771 #ifdef MACOS_TRADITIONAL
2772     case '\312':
2773 #endif
2774         s++;
2775         goto retry;
2776     case '#':
2777     case '\n':
2778         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2779             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2780                 /* handle eval qq[#line 1 "foo"\n ...] */
2781                 CopLINE_dec(PL_curcop);
2782                 incline(s);
2783             }
2784             d = PL_bufend;
2785             while (s < d && *s != '\n')
2786                 s++;
2787             if (s < d)
2788                 s++;
2789             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2790               Perl_croak(aTHX_ "panic: input overflow");
2791             incline(s);
2792             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2793                 PL_bufptr = s;
2794                 PL_lex_state = LEX_FORMLINE;
2795                 return yylex();
2796             }
2797         }
2798         else {
2799             *s = '\0';
2800             PL_bufend = s;
2801         }
2802         goto retry;
2803     case '-':
2804         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2805             I32 ftst = 0;
2806
2807             s++;
2808             PL_bufptr = s;
2809             tmp = *s++;
2810
2811             while (s < PL_bufend && SPACE_OR_TAB(*s))
2812                 s++;
2813
2814             if (strnEQ(s,"=>",2)) {
2815                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2816                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2817                             "### Saw unary minus before =>, forcing word '%s'\n", s);
2818                 } );
2819                 OPERATOR('-');          /* unary minus */
2820             }
2821             PL_last_uni = PL_oldbufptr;
2822             switch (tmp) {
2823             case 'r': ftst = OP_FTEREAD;        break;
2824             case 'w': ftst = OP_FTEWRITE;       break;
2825             case 'x': ftst = OP_FTEEXEC;        break;
2826             case 'o': ftst = OP_FTEOWNED;       break;
2827             case 'R': ftst = OP_FTRREAD;        break;
2828             case 'W': ftst = OP_FTRWRITE;       break;
2829             case 'X': ftst = OP_FTREXEC;        break;
2830             case 'O': ftst = OP_FTROWNED;       break;
2831             case 'e': ftst = OP_FTIS;           break;
2832             case 'z': ftst = OP_FTZERO;         break;
2833             case 's': ftst = OP_FTSIZE;         break;
2834             case 'f': ftst = OP_FTFILE;         break;
2835             case 'd': ftst = OP_FTDIR;          break;
2836             case 'l': ftst = OP_FTLINK;         break;
2837             case 'p': ftst = OP_FTPIPE;         break;
2838             case 'S': ftst = OP_FTSOCK;         break;
2839             case 'u': ftst = OP_FTSUID;         break;
2840             case 'g': ftst = OP_FTSGID;         break;
2841             case 'k': ftst = OP_FTSVTX;         break;
2842             case 'b': ftst = OP_FTBLK;          break;
2843             case 'c': ftst = OP_FTCHR;          break;
2844             case 't': ftst = OP_FTTTY;          break;
2845             case 'T': ftst = OP_FTTEXT;         break;
2846             case 'B': ftst = OP_FTBINARY;       break;
2847             case 'M': case 'A': case 'C':
2848                 gv_fetchpv("\024",TRUE, SVt_PV);
2849                 switch (tmp) {
2850                 case 'M': ftst = OP_FTMTIME;    break;
2851                 case 'A': ftst = OP_FTATIME;    break;
2852                 case 'C': ftst = OP_FTCTIME;    break;
2853                 default:                        break;
2854                 }
2855                 break;
2856             default:
2857                 break;
2858             }
2859             if (ftst) {
2860                 PL_last_lop_op = ftst;
2861                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2862                         "### Saw file test %c\n", (int)ftst);
2863                 } );
2864                 FTST(ftst);
2865             }
2866             else {
2867                 /* Assume it was a minus followed by a one-letter named
2868                  * subroutine call (or a -bareword), then. */
2869                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2870                         "### %c looked like a file test but was not\n",
2871                         (int)ftst);
2872                 } );
2873                 s -= 2;
2874             }
2875         }
2876         tmp = *s++;
2877         if (*s == tmp) {
2878             s++;
2879             if (PL_expect == XOPERATOR)
2880                 TERM(POSTDEC);
2881             else
2882                 OPERATOR(PREDEC);
2883         }
2884         else if (*s == '>') {
2885             s++;
2886             s = skipspace(s);
2887             if (isIDFIRST_lazy_if(s,UTF)) {
2888                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2889                 TOKEN(ARROW);
2890             }
2891             else if (*s == '$')
2892                 OPERATOR(ARROW);
2893             else
2894                 TERM(ARROW);
2895         }
2896         if (PL_expect == XOPERATOR)
2897             Aop(OP_SUBTRACT);
2898         else {
2899             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2900                 check_uni();
2901             OPERATOR('-');              /* unary minus */
2902         }
2903
2904     case '+':
2905         tmp = *s++;
2906         if (*s == tmp) {
2907             s++;
2908             if (PL_expect == XOPERATOR)
2909                 TERM(POSTINC);
2910             else
2911                 OPERATOR(PREINC);
2912         }
2913         if (PL_expect == XOPERATOR)
2914             Aop(OP_ADD);
2915         else {
2916             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2917                 check_uni();
2918             OPERATOR('+');
2919         }
2920
2921     case '*':
2922         if (PL_expect != XOPERATOR) {
2923             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2924             PL_expect = XOPERATOR;
2925             force_ident(PL_tokenbuf, '*');
2926             if (!*PL_tokenbuf)
2927                 PREREF('*');
2928             TERM('*');
2929         }
2930         s++;
2931         if (*s == '*') {
2932             s++;
2933             PWop(OP_POW);
2934         }
2935         Mop(OP_MULTIPLY);
2936
2937     case '%':
2938         if (PL_expect == XOPERATOR) {
2939             ++s;
2940             Mop(OP_MODULO);
2941         }
2942         PL_tokenbuf[0] = '%';
2943         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2944         if (!PL_tokenbuf[1]) {
2945             if (s == PL_bufend)
2946                 yyerror("Final % should be \\% or %name");
2947             PREREF('%');
2948         }
2949         PL_pending_ident = '%';
2950         TERM('%');
2951
2952     case '^':
2953         s++;
2954         BOop(OP_BIT_XOR);
2955     case '[':
2956         PL_lex_brackets++;
2957         /* FALL THROUGH */
2958     case '~':
2959     case ',':
2960         tmp = *s++;
2961         OPERATOR(tmp);
2962     case ':':
2963         if (s[1] == ':') {
2964             len = 0;
2965             goto just_a_word;
2966         }
2967         s++;
2968         switch (PL_expect) {
2969             OP *attrs;
2970         case XOPERATOR:
2971             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2972                 break;
2973             PL_bufptr = s;      /* update in case we back off */
2974             goto grabattrs;
2975         case XATTRBLOCK:
2976             PL_expect = XBLOCK;
2977             goto grabattrs;
2978         case XATTRTERM:
2979             PL_expect = XTERMBLOCK;
2980          grabattrs:
2981             s = skipspace(s);
2982             attrs = Nullop;
2983             while (isIDFIRST_lazy_if(s,UTF)) {
2984                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2985                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2986                     if (tmp < 0) tmp = -tmp;
2987                     switch (tmp) {
2988                     case KEY_or:
2989                     case KEY_and:
2990                     case KEY_for:
2991                     case KEY_unless:
2992                     case KEY_if:
2993                     case KEY_while:
2994                     case KEY_until:
2995                         goto got_attrs;
2996                     default:
2997                         break;
2998                     }
2999                 }
3000                 if (*d == '(') {
3001                     d = scan_str(d,TRUE,TRUE);
3002                     if (!d) {
3003                         /* MUST advance bufptr here to avoid bogus
3004                            "at end of line" context messages from yyerror().
3005                          */
3006                         PL_bufptr = s + len;
3007                         yyerror("Unterminated attribute parameter in attribute list");
3008                         if (attrs)
3009                             op_free(attrs);
3010                         return 0;       /* EOF indicator */
3011                     }
3012                 }
3013                 if (PL_lex_stuff) {
3014                     SV *sv = newSVpvn(s, len);
3015                     sv_catsv(sv, PL_lex_stuff);
3016                     attrs = append_elem(OP_LIST, attrs,
3017                                         newSVOP(OP_CONST, 0, sv));
3018                     SvREFCNT_dec(PL_lex_stuff);
3019                     PL_lex_stuff = Nullsv;
3020                 }
3021                 else {
3022                     if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3023                         CvLVALUE_on(PL_compcv);
3024                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3025                         CvLOCKED_on(PL_compcv);
3026                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3027                         CvMETHOD_on(PL_compcv);
3028 #ifdef USE_ITHREADS
3029       else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "unique", len))
3030                         GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3031 #endif
3032                     /* After we've set the flags, it could be argued that
3033                        we don't need to do the attributes.pm-based setting
3034                        process, and shouldn't bother appending recognized
3035                        flags. To experiment with that, uncomment the
3036                        following "else": */
3037                     else
3038                         attrs = append_elem(OP_LIST, attrs,
3039                                             newSVOP(OP_CONST, 0,
3040                                                     newSVpvn(s, len)));
3041                 }
3042                 s = skipspace(d);
3043                 if (*s == ':' && s[1] != ':')
3044                     s = skipspace(s+1);
3045                 else if (s == d)
3046                     break;      /* require real whitespace or :'s */
3047             }
3048             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3049             if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
3050                 char q = ((*s == '\'') ? '"' : '\'');
3051                 /* If here for an expression, and parsed no attrs, back off. */
3052                 if (tmp == '=' && !attrs) {
3053                     s = PL_bufptr;
3054                     break;
3055                 }
3056                 /* MUST advance bufptr here to avoid bogus "at end of line"
3057                    context messages from yyerror().
3058                  */
3059                 PL_bufptr = s;
3060                 if (!*s)
3061                     yyerror("Unterminated attribute list");
3062                 else
3063                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3064                                       q, *s, q));
3065                 if (attrs)
3066                     op_free(attrs);
3067                 OPERATOR(':');
3068             }
3069         got_attrs:
3070             if (attrs) {
3071                 PL_nextval[PL_nexttoke].opval = attrs;
3072                 force_next(THING);
3073             }
3074             TOKEN(COLONATTR);
3075         }
3076         OPERATOR(':');
3077     case '(':
3078         s++;
3079         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3080             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3081         else
3082             PL_expect = XTERM;
3083         TOKEN('(');
3084     case ';':
3085         CLINE;
3086         tmp = *s++;
3087         OPERATOR(tmp);
3088     case ')':
3089         tmp = *s++;
3090         s = skipspace(s);
3091         if (*s == '{')
3092             PREBLOCK(tmp);
3093         TERM(tmp);
3094     case ']':
3095         s++;
3096         if (PL_lex_brackets <= 0)
3097             yyerror("Unmatched right square bracket");
3098         else
3099             --PL_lex_brackets;
3100         if (PL_lex_state == LEX_INTERPNORMAL) {
3101             if (PL_lex_brackets == 0) {
3102                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3103                     PL_lex_state = LEX_INTERPEND;
3104             }
3105         }
3106         TERM(']');
3107     case '{':
3108       leftbracket:
3109         s++;
3110         if (PL_lex_brackets > 100) {
3111             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3112             if (newlb != PL_lex_brackstack) {
3113                 SAVEFREEPV(newlb);
3114                 PL_lex_brackstack = newlb;
3115             }
3116         }
3117         switch (PL_expect) {
3118         case XTERM:
3119             if (PL_lex_formbrack) {
3120                 s--;
3121                 PRETERMBLOCK(DO);
3122             }
3123             if (PL_oldoldbufptr == PL_last_lop)
3124                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3125             else
3126                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3127             OPERATOR(HASHBRACK);
3128         case XOPERATOR:
3129             while (s < PL_bufend && SPACE_OR_TAB(*s))
3130                 s++;
3131             d = s;
3132             PL_tokenbuf[0] = '\0';
3133             if (d < PL_bufend && *d == '-') {
3134                 PL_tokenbuf[0] = '-';
3135                 d++;
3136                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3137                     d++;
3138             }
3139             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3140                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3141                               FALSE, &len);
3142                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3143                     d++;
3144                 if (*d == '}') {
3145                     char minus = (PL_tokenbuf[0] == '-');
3146                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3147                     if (minus)
3148                         force_next('-');
3149                 }
3150             }
3151             /* FALL THROUGH */
3152         case XATTRBLOCK:
3153         case XBLOCK:
3154             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3155             PL_expect = XSTATE;
3156             break;
3157         case XATTRTERM:
3158         case XTERMBLOCK:
3159             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3160             PL_expect = XSTATE;
3161             break;
3162         default: {
3163                 char *t;
3164                 if (PL_oldoldbufptr == PL_last_lop)
3165                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3166                 else
3167                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3168                 s = skipspace(s);
3169                 if (*s == '}') {
3170                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3171                         PL_expect = XTERM;
3172                         /* This hack is to get the ${} in the message. */
3173                         PL_bufptr = s+1;
3174                         yyerror("syntax error");
3175                         break;
3176                     }
3177                     OPERATOR(HASHBRACK);
3178                 }
3179                 /* This hack serves to disambiguate a pair of curlies
3180                  * as being a block or an anon hash.  Normally, expectation
3181                  * determines that, but in cases where we're not in a
3182                  * position to expect anything in particular (like inside
3183                  * eval"") we have to resolve the ambiguity.  This code
3184                  * covers the case where the first term in the curlies is a
3185                  * quoted string.  Most other cases need to be explicitly
3186                  * disambiguated by prepending a `+' before the opening
3187                  * curly in order to force resolution as an anon hash.
3188                  *
3189                  * XXX should probably propagate the outer expectation
3190                  * into eval"" to rely less on this hack, but that could
3191                  * potentially break current behavior of eval"".
3192                  * GSAR 97-07-21
3193                  */
3194                 t = s;
3195                 if (*s == '\'' || *s == '"' || *s == '`') {
3196                     /* common case: get past first string, handling escapes */
3197                     for (t++; t < PL_bufend && *t != *s;)
3198                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3199                             t++;
3200                     t++;
3201                 }
3202                 else if (*s == 'q') {
3203                     if (++t < PL_bufend
3204                         && (!isALNUM(*t)
3205                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3206                                 && !isALNUM(*t))))
3207                     {
3208                         char *tmps;
3209                         char open, close, term;
3210                         I32 brackets = 1;
3211
3212                         while (t < PL_bufend && isSPACE(*t))
3213                             t++;
3214                         term = *t;
3215                         open = term;
3216                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3217                             term = tmps[5];
3218                         close = term;
3219                         if (open == close)
3220                             for (t++; t < PL_bufend; t++) {
3221                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3222                                     t++;
3223                                 else if (*t == open)
3224                                     break;
3225                             }
3226                         else
3227                             for (t++; t < PL_bufend; t++) {
3228                                 if (*t == '\\' && t+1 < PL_bufend)
3229                                     t++;
3230                                 else if (*t == close && --brackets <= 0)
3231                                     break;
3232                                 else if (*t == open)
3233                                     brackets++;
3234                             }
3235                     }
3236                     t++;
3237                 }
3238                 else if (isALNUM_lazy_if(t,UTF)) {
3239                     t += UTF8SKIP(t);
3240                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3241                          t += UTF8SKIP(t);
3242                 }
3243                 while (t < PL_bufend && isSPACE(*t))
3244                     t++;
3245                 /* if comma follows first term, call it an anon hash */
3246                 /* XXX it could be a comma expression with loop modifiers */
3247                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3248                                    || (*t == '=' && t[1] == '>')))
3249                     OPERATOR(HASHBRACK);
3250                 if (PL_expect == XREF)
3251                     PL_expect = XTERM;
3252                 else {
3253                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3254                     PL_expect = XSTATE;
3255                 }
3256             }
3257             break;
3258         }
3259         yylval.ival = CopLINE(PL_curcop);
3260         if (isSPACE(*s) || *s == '#')
3261             PL_copline = NOLINE;   /* invalidate current command line number */
3262         TOKEN('{');
3263     case '}':
3264       rightbracket:
3265         s++;
3266         if (PL_lex_brackets <= 0)
3267             yyerror("Unmatched right curly bracket");
3268         else
3269             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3270         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3271             PL_lex_formbrack = 0;
3272         if (PL_lex_state == LEX_INTERPNORMAL) {
3273             if (PL_lex_brackets == 0) {
3274                 if (PL_expect & XFAKEBRACK) {
3275                     PL_expect &= XENUMMASK;
3276                     PL_lex_state = LEX_INTERPEND;
3277                     PL_bufptr = s;
3278                     return yylex();     /* ignore fake brackets */
3279                 }
3280                 if (*s == '-' && s[1] == '>')
3281                     PL_lex_state = LEX_INTERPENDMAYBE;
3282                 else if (*s != '[' && *s != '{')
3283                     PL_lex_state = LEX_INTERPEND;
3284             }
3285         }
3286         if (PL_expect & XFAKEBRACK) {
3287             PL_expect &= XENUMMASK;
3288             PL_bufptr = s;
3289             return yylex();             /* ignore fake brackets */
3290         }
3291         force_next('}');
3292         TOKEN(';');
3293     case '&':
3294         s++;
3295         tmp = *s++;
3296         if (tmp == '&')
3297             AOPERATOR(ANDAND);
3298         s--;
3299         if (PL_expect == XOPERATOR) {
3300             if (ckWARN(WARN_SEMICOLON)
3301                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3302             {
3303                 CopLINE_dec(PL_curcop);
3304                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3305                 CopLINE_inc(PL_curcop);
3306             }
3307             BAop(OP_BIT_AND);
3308         }
3309
3310         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3311         if (*PL_tokenbuf) {
3312             PL_expect = XOPERATOR;
3313             force_ident(PL_tokenbuf, '&');
3314         }
3315         else
3316             PREREF('&');
3317         yylval.ival = (OPpENTERSUB_AMPER<<8);
3318         TERM('&');
3319
3320     case '|':
3321         s++;
3322         tmp = *s++;
3323         if (tmp == '|')
3324             AOPERATOR(OROR);
3325         s--;
3326         BOop(OP_BIT_OR);
3327     case '=':
3328         s++;
3329         tmp = *s++;
3330         if (tmp == '=')
3331             Eop(OP_EQ);
3332         if (tmp == '>')
3333             OPERATOR(',');
3334         if (tmp == '~')
3335             PMop(OP_MATCH);
3336         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3337             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3338         s--;
3339         if (PL_expect == XSTATE && isALPHA(tmp) &&
3340                 (s == PL_linestart+1 || s[-2] == '\n') )
3341         {
3342             if (PL_in_eval && !PL_rsfp) {
3343                 d = PL_bufend;
3344                 while (s < d) {
3345                     if (*s++ == '\n') {
3346                         incline(s);
3347                         if (strnEQ(s,"=cut",4)) {
3348                             s = strchr(s,'\n');
3349                             if (s)
3350                                 s++;
3351                             else
3352                                 s = d;
3353                             incline(s);
3354                             goto retry;
3355                         }
3356                     }
3357                 }
3358                 goto retry;
3359             }
3360             s = PL_bufend;
3361             PL_doextract = TRUE;
3362             goto retry;
3363         }
3364         if (PL_lex_brackets < PL_lex_formbrack) {
3365             char *t;
3366 #ifdef PERL_STRICT_CR
3367             for (t = s; SPACE_OR_TAB(*t); t++) ;
3368 #else
3369             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3370 #endif
3371             if (*t == '\n' || *t == '#') {
3372                 s--;
3373                 PL_expect = XBLOCK;
3374                 goto leftbracket;
3375             }
3376         }
3377         yylval.ival = 0;
3378         OPERATOR(ASSIGNOP);
3379     case '!':
3380         s++;
3381         tmp = *s++;
3382         if (tmp == '=')
3383             Eop(OP_NE);
3384         if (tmp == '~')
3385             PMop(OP_NOT);
3386         s--;
3387         OPERATOR('!');
3388     case '<':
3389         if (PL_expect != XOPERATOR) {
3390             if (s[1] != '<' && !strchr(s,'>'))
3391                 check_uni();
3392             if (s[1] == '<')
3393                 s = scan_heredoc(s);
3394             else
3395                 s = scan_inputsymbol(s);
3396             TERM(sublex_start());
3397         }
3398         s++;
3399         tmp = *s++;
3400         if (tmp == '<')
3401             SHop(OP_LEFT_SHIFT);
3402         if (tmp == '=') {
3403             tmp = *s++;
3404             if (tmp == '>')
3405                 Eop(OP_NCMP);
3406             s--;
3407             Rop(OP_LE);
3408         }
3409         s--;
3410         Rop(OP_LT);
3411     case '>':
3412         s++;
3413         tmp = *s++;
3414         if (tmp == '>')
3415             SHop(OP_RIGHT_SHIFT);
3416         if (tmp == '=')
3417             Rop(OP_GE);
3418         s--;
3419         Rop(OP_GT);
3420
3421     case '$':
3422         CLINE;
3423
3424         if (PL_expect == XOPERATOR) {
3425             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3426                 PL_expect = XTERM;
3427                 depcom();
3428                 return ','; /* grandfather non-comma-format format */
3429             }
3430         }
3431
3432         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3433             PL_tokenbuf[0] = '@';
3434             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3435                            sizeof PL_tokenbuf - 1, FALSE);
3436             if (PL_expect == XOPERATOR)
3437                 no_op("Array length", s);
3438             if (!PL_tokenbuf[1])
3439                 PREREF(DOLSHARP);
3440             PL_expect = XOPERATOR;
3441             PL_pending_ident = '#';
3442             TOKEN(DOLSHARP);
3443         }
3444
3445         PL_tokenbuf[0] = '$';
3446         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3447                        sizeof PL_tokenbuf - 1, FALSE);
3448         if (PL_expect == XOPERATOR)
3449             no_op("Scalar", s);
3450         if (!PL_tokenbuf[1]) {
3451             if (s == PL_bufend)
3452                 yyerror("Final $ should be \\$ or $name");
3453             PREREF('$');
3454         }
3455
3456         /* This kludge not intended to be bulletproof. */
3457         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3458             yylval.opval = newSVOP(OP_CONST, 0,
3459                                    newSViv(PL_compiling.cop_arybase));
3460             yylval.opval->op_private = OPpCONST_ARYBASE;
3461             TERM(THING);
3462         }
3463
3464         d = s;
3465         tmp = (I32)*s;
3466         if (PL_lex_state == LEX_NORMAL)
3467             s = skipspace(s);
3468
3469         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3470             char *t;
3471             if (*s == '[') {
3472                 PL_tokenbuf[0] = '@';
3473                 if (ckWARN(WARN_SYNTAX)) {
3474                     for(t = s + 1;
3475                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3476                         t++) ;
3477                     if (*t++ == ',') {
3478                         PL_bufptr = skipspace(PL_bufptr);
3479                         while (t < PL_bufend && *t != ']')
3480                             t++;
3481                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3482                                 "Multidimensional syntax %.*s not supported",
3483                                 (t - PL_bufptr) + 1, PL_bufptr);
3484                     }
3485                 }
3486             }
3487             else if (*s == '{') {
3488                 PL_tokenbuf[0] = '%';
3489                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3490                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3491                 {
3492                     char tmpbuf[sizeof PL_tokenbuf];
3493                     STRLEN len;
3494                     for (t++; isSPACE(*t); t++) ;
3495                     if (isIDFIRST_lazy_if(t,UTF)) {
3496                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3497                         for (; isSPACE(*t); t++) ;
3498                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3499                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3500                                 "You need to quote \"%s\"", tmpbuf);
3501                     }
3502                 }
3503             }
3504         }
3505
3506         PL_expect = XOPERATOR;
3507         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3508             bool islop = (PL_last_lop == PL_oldoldbufptr);
3509             if (!islop || PL_last_lop_op == OP_GREPSTART)
3510                 PL_expect = XOPERATOR;
3511             else if (strchr("$@\"'`q", *s))
3512                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3513             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3514                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3515             else if (isIDFIRST_lazy_if(s,UTF)) {
3516                 char tmpbuf[sizeof PL_tokenbuf];
3517                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3518                 if ((tmp = keyword(tmpbuf, len))) {
3519                     /* binary operators exclude handle interpretations */
3520                     switch (tmp) {
3521                     case -KEY_x:
3522                     case -KEY_eq:
3523                     case -KEY_ne:
3524                     case -KEY_gt:
3525                     case -KEY_lt:
3526                     case -KEY_ge:
3527                     case -KEY_le:
3528                     case -KEY_cmp:
3529                         break;
3530                     default:
3531                         PL_expect = XTERM;      /* e.g. print $fh length() */
3532                         break;
3533                     }
3534                 }
3535                 else {
3536                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3537                     if (gv && GvCVu(gv))
3538                         PL_expect = XTERM;      /* e.g. print $fh subr() */
3539                 }
3540             }
3541             else if (isDIGIT(*s))
3542                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3543             else if (*s == '.' && isDIGIT(s[1]))
3544                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3545             else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3546                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3547             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3548                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3549         }
3550         PL_pending_ident = '$';
3551         TOKEN('$');
3552
3553     case '@':
3554         if (PL_expect == XOPERATOR)
3555             no_op("Array", s);
3556         PL_tokenbuf[0] = '@';
3557         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3558         if (!PL_tokenbuf[1]) {
3559             if (s == PL_bufend)
3560                 yyerror("Final @ should be \\@ or @name");
3561             PREREF('@');
3562         }
3563         if (PL_lex_state == LEX_NORMAL)
3564             s = skipspace(s);
3565         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3566             if (*s == '{')
3567                 PL_tokenbuf[0] = '%';
3568
3569             /* Warn about @ where they meant $. */
3570             if (ckWARN(WARN_SYNTAX)) {
3571                 if (*s == '[' || *s == '{') {
3572                     char *t = s + 1;
3573                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3574                         t++;
3575                     if (*t == '}' || *t == ']') {
3576                         t++;
3577                         PL_bufptr = skipspace(PL_bufptr);
3578                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3579                             "Scalar value %.*s better written as $%.*s",
3580                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3581                     }
3582                 }
3583             }
3584         }
3585         PL_pending_ident = '@';
3586         TERM('@');
3587
3588     case '/':                   /* may either be division or pattern */
3589     case '?':                   /* may either be conditional or pattern */
3590         if (PL_expect != XOPERATOR) {
3591             /* Disable warning on "study /blah/" */
3592             if (PL_oldoldbufptr == PL_last_uni
3593                 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3594                     || memNE(PL_last_uni, "study", 5)
3595                     || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3596                 check_uni();
3597             s = scan_pat(s,OP_MATCH);
3598             TERM(sublex_start());
3599         }
3600         tmp = *s++;
3601         if (tmp == '/')
3602             Mop(OP_DIVIDE);
3603         OPERATOR(tmp);
3604
3605     case '.':
3606         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3607 #ifdef PERL_STRICT_CR
3608             && s[1] == '\n'
3609 #else
3610             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3611 #endif
3612             && (s == PL_linestart || s[-1] == '\n') )
3613         {
3614             PL_lex_formbrack = 0;
3615             PL_expect = XSTATE;
3616             goto rightbracket;
3617         }
3618         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3619             tmp = *s++;
3620             if (*s == tmp) {
3621                 s++;
3622                 if (*s == tmp) {
3623                     s++;
3624                     yylval.ival = OPf_SPECIAL;
3625                 }
3626                 else
3627                     yylval.ival = 0;
3628                 OPERATOR(DOTDOT);
3629             }
3630             if (PL_expect != XOPERATOR)
3631                 check_uni();
3632             Aop(OP_CONCAT);
3633         }
3634         /* FALL THROUGH */
3635     case '0': case '1': case '2': case '3': case '4':
3636     case '5': case '6': case '7': case '8': case '9':
3637         s = scan_num(s, &yylval);
3638         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3639                     "### Saw number in '%s'\n", s);
3640         } );
3641         if (PL_expect == XOPERATOR)
3642             no_op("Number",s);
3643         TERM(THING);
3644
3645     case '\'':
3646         s = scan_str(s,FALSE,FALSE);
3647         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3648                     "### Saw string before '%s'\n", s);
3649         } );
3650         if (PL_expect == XOPERATOR) {
3651             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3652                 PL_expect = XTERM;
3653                 depcom();
3654                 return ',';     /* grandfather non-comma-format format */
3655             }
3656             else
3657                 no_op("String",s);
3658         }
3659         if (!s)
3660             missingterm((char*)0);
3661         yylval.ival = OP_CONST;
3662         TERM(sublex_start());
3663
3664     case '"':
3665         s = scan_str(s,FALSE,FALSE);
3666         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3667                     "### Saw string before '%s'\n", s);
3668         } );
3669         if (PL_expect == XOPERATOR) {
3670             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3671                 PL_expect = XTERM;
3672                 depcom();
3673                 return ',';     /* grandfather non-comma-format format */
3674             }
3675             else
3676                 no_op("String",s);
3677         }
3678         if (!s)
3679             missingterm((char*)0);
3680         yylval.ival = OP_CONST;
3681         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3682             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3683                 yylval.ival = OP_STRINGIFY;
3684                 break;
3685             }
3686         }
3687         TERM(sublex_start());
3688
3689     case '`':
3690         s = scan_str(s,FALSE,FALSE);
3691         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3692                     "### Saw backtick string before '%s'\n", s);
3693         } );
3694         if (PL_expect == XOPERATOR)
3695             no_op("Backticks",s);
3696         if (!s)
3697             missingterm((char*)0);
3698         yylval.ival = OP_BACKTICK;
3699         set_csh();
3700         TERM(sublex_start());
3701
3702     case '\\':
3703         s++;
3704         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3705             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3706                         *s, *s);
3707         if (PL_expect == XOPERATOR)
3708             no_op("Backslash",s);
3709         OPERATOR(REFGEN);
3710
3711     case 'v':
3712         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3713             char *start = s;
3714             start++;
3715             start++;
3716             while (isDIGIT(*start) || *start == '_')
3717                 start++;
3718             if (*start == '.' && isDIGIT(start[1])) {
3719                 s = scan_num(s, &yylval);
3720                 TERM(THING);
3721             }
3722             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3723             else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
3724                 char c = *start;
3725                 GV *gv;
3726                 *start = '\0';
3727                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3728                 *start = c;
3729                 if (!gv) {
3730                     s = scan_num(s, &yylval);
3731                     TERM(THING);
3732                 }
3733             }
3734         }
3735         goto keylookup;
3736     case 'x':
3737         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3738             s++;
3739             Mop(OP_REPEAT);
3740         }
3741         goto keylookup;
3742
3743     case '_':
3744     case 'a': case 'A':
3745     case 'b': case 'B':
3746     case 'c': case 'C':
3747     case 'd': case 'D':
3748     case 'e': case 'E':
3749     case 'f': case 'F':
3750     case 'g': case 'G':
3751     case 'h': case 'H':
3752     case 'i': case 'I':
3753     case 'j': case 'J':
3754     case 'k': case 'K':
3755     case 'l': case 'L':
3756     case 'm': case 'M':
3757     case 'n': case 'N':
3758     case 'o': case 'O':
3759     case 'p': case 'P':
3760     case 'q': case 'Q':
3761     case 'r': case 'R':
3762     case 's': case 'S':
3763     case 't': case 'T':
3764     case 'u': case 'U':
3765               case 'V':
3766     case 'w': case 'W':
3767               case 'X':
3768     case 'y': case 'Y':
3769     case 'z': case 'Z':
3770
3771       keylookup: {
3772         gv = Nullgv;
3773         gvp = 0;
3774
3775         PL_bufptr = s;
3776         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3777
3778         /* Some keywords can be followed by any delimiter, including ':' */
3779         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3780                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3781                              (PL_tokenbuf[0] == 'q' &&
3782                               strchr("qwxr", PL_tokenbuf[1])))));
3783
3784         /* x::* is just a word, unless x is "CORE" */
3785         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3786             goto just_a_word;
3787
3788         d = s;
3789         while (d < PL_bufend && isSPACE(*d))
3790                 d++;    /* no comments skipped here, or s### is misparsed */
3791
3792         /* Is this a label? */
3793         if (!tmp && PL_expect == XSTATE
3794               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3795             s = d + 1;
3796             yylval.pval = savepv(PL_tokenbuf);
3797             CLINE;
3798             TOKEN(LABEL);
3799         }
3800
3801         /* Check for keywords */
3802         tmp = keyword(PL_tokenbuf, len);
3803
3804         /* Is this a word before a => operator? */
3805         if (*d == '=' && d[1] == '>') {
3806             CLINE;
3807             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3808             yylval.opval->op_private = OPpCONST_BARE;
3809             if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3810               SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3811             TERM(WORD);
3812         }
3813
3814         if (tmp < 0) {                  /* second-class keyword? */
3815             GV *ogv = Nullgv;   /* override (winner) */
3816             GV *hgv = Nullgv;   /* hidden (loser) */
3817             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3818                 CV *cv;
3819                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3820                     (cv = GvCVu(gv)))
3821                 {
3822                     if (GvIMPORTED_CV(gv))
3823                         ogv = gv;
3824                     else if (! CvMETHOD(cv))
3825                         hgv = gv;
3826                 }
3827                 if (!ogv &&
3828                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3829                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3830                     GvCVu(gv) && GvIMPORTED_CV(gv))
3831                 {
3832                     ogv = gv;
3833                 }
3834             }
3835             if (ogv) {
3836                 tmp = 0;                /* overridden by import or by GLOBAL */
3837             }
3838             else if (gv && !gvp
3839                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3840                      && GvCVu(gv)
3841                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3842             {
3843                 tmp = 0;                /* any sub overrides "weak" keyword */
3844             }
3845             else {                      /* no override */
3846                 tmp = -tmp;
3847                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
3848                     Perl_warner(aTHX_ packWARN(WARN_MISC),
3849                             "dump() better written as CORE::dump()");
3850                 }
3851                 gv = Nullgv;
3852                 gvp = 0;
3853                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3854                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3855                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3856                         "Ambiguous call resolved as CORE::%s(), %s",
3857                          GvENAME(hgv), "qualify as such or use &");
3858             }
3859         }
3860
3861       reserved_word:
3862         switch (tmp) {
3863
3864         default:                        /* not a keyword */
3865           just_a_word: {
3866                 SV *sv;
3867                 int pkgname = 0;
3868                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3869
3870                 /* Get the rest if it looks like a package qualifier */
3871
3872                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3873                     STRLEN morelen;
3874                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3875                                   TRUE, &morelen);
3876                     if (!morelen)
3877                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3878                                 *s == '\'' ? "'" : "::");
3879                     len += morelen;
3880                     pkgname = 1;
3881                 }
3882
3883                 if (PL_expect == XOPERATOR) {
3884                     if (PL_bufptr == PL_linestart) {
3885                         CopLINE_dec(PL_curcop);
3886                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3887                         CopLINE_inc(PL_curcop);
3888                     }
3889                     else
3890                         no_op("Bareword",s);
3891                 }
3892
3893                 /* Look for a subroutine with this name in current package,
3894                    unless name is "Foo::", in which case Foo is a bearword
3895                    (and a package name). */
3896
3897                 if (len > 2 &&
3898                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3899                 {
3900                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3901                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
3902                             "Bareword \"%s\" refers to nonexistent package",
3903                              PL_tokenbuf);
3904                     len -= 2;
3905                     PL_tokenbuf[len] = '\0';
3906                     gv = Nullgv;
3907                     gvp = 0;
3908                 }
3909                 else {
3910                     len = 0;
3911                     if (!gv)
3912                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3913                 }
3914
3915                 /* if we saw a global override before, get the right name */
3916
3917                 if (gvp) {
3918                     sv = newSVpvn("CORE::GLOBAL::",14);
3919                     sv_catpv(sv,PL_tokenbuf);
3920                 }
3921                 else
3922                     sv = newSVpv(PL_tokenbuf,0);
3923
3924                 /* Presume this is going to be a bareword of some sort. */
3925
3926                 CLINE;
3927                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3928                 yylval.opval->op_private = OPpCONST_BARE;
3929
3930                 /* And if "Foo::", then that's what it certainly is. */
3931
3932                 if (len)
3933                     goto safe_bareword;
3934
3935                 /* See if it's the indirect object for a list operator. */
3936
3937                 if (PL_oldoldbufptr &&
3938                     PL_oldoldbufptr < PL_bufptr &&
3939                     (PL_oldoldbufptr == PL_last_lop
3940                      || PL_oldoldbufptr == PL_last_uni) &&
3941                     /* NO SKIPSPACE BEFORE HERE! */
3942                     (PL_expect == XREF ||
3943                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3944                 {
3945                     bool immediate_paren = *s == '(';
3946
3947                     /* (Now we can afford to cross potential line boundary.) */
3948                     s = skipspace(s);
3949
3950                     /* Two barewords in a row may indicate method call. */
3951
3952                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3953                         return tmp;
3954
3955                     /* If not a declared subroutine, it's an indirect object. */
3956                     /* (But it's an indir obj regardless for sort.) */
3957
3958                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
3959                          ((!gv || !GvCVu(gv)) &&
3960                         (PL_last_lop_op != OP_MAPSTART &&
3961                          PL_last_lop_op != OP_GREPSTART))))
3962                     {
3963                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3964                         goto bareword;
3965                     }
3966                 }
3967
3968                 PL_expect = XOPERATOR;
3969                 s = skipspace(s);
3970
3971                 /* Is this a word before a => operator? */
3972                 if (*s == '=' && s[1] == '>' && !pkgname) {
3973                     CLINE;
3974                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3975                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3976                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3977                     TERM(WORD);
3978                 }
3979
3980                 /* If followed by a paren, it's certainly a subroutine. */
3981                 if (*s == '(') {
3982                     CLINE;
3983                     if (gv && GvCVu(gv)) {
3984                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3985                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3986                             s = d + 1;
3987                             goto its_constant;
3988                         }
3989                     }
3990                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3991                     PL_expect = XOPERATOR;
3992                     force_next(WORD);
3993                     yylval.ival = 0;
3994                     TOKEN('&');
3995                 }
3996
3997                 /* If followed by var or block, call it a method (unless sub) */
3998
3999                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4000                     PL_last_lop = PL_oldbufptr;
4001                     PL_last_lop_op = OP_METHOD;
4002                     PREBLOCK(METHOD);
4003                 }
4004
4005                 /* If followed by a bareword, see if it looks like indir obj. */
4006
4007                 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
4008                     return tmp;
4009
4010                 /* Not a method, so call it a subroutine (if defined) */
4011
4012                 if (gv && GvCVu(gv)) {
4013                     CV* cv;
4014                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4015                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4016                                 "Ambiguous use of -%s resolved as -&%s()",
4017                                 PL_tokenbuf, PL_tokenbuf);
4018                     /* Check for a constant sub */
4019                     cv = GvCV(gv);
4020                     if ((sv = cv_const_sv(cv))) {
4021                   its_constant:
4022                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4023                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4024                         yylval.opval->op_private = 0;
4025                         TOKEN(WORD);
4026                     }
4027
4028                     /* Resolve to GV now. */
4029                     op_free(yylval.opval);
4030                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4031                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4032                     PL_last_lop = PL_oldbufptr;
4033                     PL_last_lop_op = OP_ENTERSUB;
4034                     /* Is there a prototype? */
4035                     if (SvPOK(cv)) {
4036                         STRLEN len;
4037                         char *proto = SvPV((SV*)cv, len);
4038                         if (!len)
4039                             TERM(FUNC0SUB);
4040                         if (strEQ(proto, "$"))
4041                             OPERATOR(UNIOPSUB);
4042                         if (*proto == '&' && *s == '{') {
4043                             sv_setpv(PL_subname, PL_curstash ? 
4044                                         "__ANON__" : "__ANON__::__ANON__");
4045                             PREBLOCK(LSTOPSUB);
4046                         }
4047                     }
4048                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4049                     PL_expect = XTERM;
4050                     force_next(WORD);
4051                     TOKEN(NOAMP);
4052                 }
4053
4054                 /* Call it a bare word */
4055
4056                 if (PL_hints & HINT_STRICT_SUBS)
4057                     yylval.opval->op_private |= OPpCONST_STRICT;
4058                 else {
4059                 bareword:
4060                     if (ckWARN(WARN_RESERVED)) {
4061                         if (lastchar != '-') {
4062                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4063                             if (!*d && strNE(PL_tokenbuf,"main"))
4064                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4065                                        PL_tokenbuf);
4066                         }
4067                     }
4068                 }
4069
4070             safe_bareword:
4071                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4072                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4073                         "Operator or semicolon missing before %c%s",
4074                         lastchar, PL_tokenbuf);
4075                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4076                         "Ambiguous use of %c resolved as operator %c",
4077                         lastchar, lastchar);
4078                 }
4079                 TOKEN(WORD);
4080             }
4081
4082         case KEY___FILE__:
4083             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4084                                         newSVpv(CopFILE(PL_curcop),0));
4085             TERM(THING);
4086
4087         case KEY___LINE__:
4088             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4089                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4090             TERM(THING);
4091
4092         case KEY___PACKAGE__:
4093             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4094                                         (PL_curstash
4095                                          ? newSVsv(PL_curstname)
4096                                          : &PL_sv_undef));
4097             TERM(THING);
4098
4099         case KEY___DATA__:
4100         case KEY___END__: {
4101             GV *gv;
4102
4103             /*SUPPRESS 560*/
4104             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4105                 char *pname = "main";
4106                 if (PL_tokenbuf[2] == 'D')
4107                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4108                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4109                 GvMULTI_on(gv);
4110                 if (!GvIO(gv))
4111                     GvIOp(gv) = newIO();
4112                 IoIFP(GvIOp(gv)) = PL_rsfp;
4113 #if defined(HAS_FCNTL) && defined(F_SETFD)
4114                 {
4115                     int fd = PerlIO_fileno(PL_rsfp);
4116                     fcntl(fd,F_SETFD,fd >= 3);
4117                 }
4118 #endif
4119                 /* Mark this internal pseudo-handle as clean */
4120                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4121                 if (PL_preprocess)
4122                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4123                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4124                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4125                 else
4126                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4127 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4128                 /* if the script was opened in binmode, we need to revert
4129                  * it to text mode for compatibility; but only iff it has CRs
4130                  * XXX this is a questionable hack at best. */
4131                 if (PL_bufend-PL_bufptr > 2
4132                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4133                 {
4134                     Off_t loc = 0;
4135                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4136                         loc = PerlIO_tell(PL_rsfp);
4137                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
4138                     }
4139 #ifdef NETWARE
4140                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4141 #else
4142                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4143 #endif  /* NETWARE */
4144 #ifdef PERLIO_IS_STDIO /* really? */
4145 #  if defined(__BORLANDC__)
4146                         /* XXX see note in do_binmode() */
4147                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4148 #  endif
4149 #endif
4150                         if (loc > 0)
4151                             PerlIO_seek(PL_rsfp, loc, 0);
4152                     }
4153                 }
4154 #endif
4155 #ifdef PERLIO_LAYERS
4156                 if (UTF && !IN_BYTES)
4157                     PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4158 #endif
4159                 PL_rsfp = Nullfp;
4160             }
4161             goto fake_eof;
4162         }
4163
4164         case KEY_AUTOLOAD:
4165         case KEY_DESTROY:
4166         case KEY_BEGIN:
4167         case KEY_CHECK:
4168         case KEY_INIT:
4169         case KEY_END:
4170             if (PL_expect == XSTATE) {
4171                 s = PL_bufptr;
4172                 goto really_sub;
4173             }
4174             goto just_a_word;
4175
4176         case KEY_CORE:
4177             if (*s == ':' && s[1] == ':') {
4178                 s += 2;
4179                 d = s;
4180                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4181                 if (!(tmp = keyword(PL_tokenbuf, len)))
4182                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4183                 if (tmp < 0)
4184                     tmp = -tmp;
4185                 goto reserved_word;
4186             }
4187             goto just_a_word;
4188
4189         case KEY_abs:
4190             UNI(OP_ABS);
4191
4192         case KEY_alarm:
4193             UNI(OP_ALARM);
4194
4195         case KEY_accept:
4196             LOP(OP_ACCEPT,XTERM);
4197
4198         case KEY_and:
4199             OPERATOR(ANDOP);
4200
4201         case KEY_atan2:
4202             LOP(OP_ATAN2,XTERM);
4203
4204         case KEY_bind:
4205             LOP(OP_BIND,XTERM);
4206
4207         case KEY_binmode:
4208             LOP(OP_BINMODE,XTERM);
4209
4210         case KEY_bless:
4211             LOP(OP_BLESS,XTERM);
4212
4213         case KEY_chop:
4214             UNI(OP_CHOP);
4215
4216         case KEY_continue:
4217             PREBLOCK(CONTINUE);
4218
4219         case KEY_chdir:
4220             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
4221             UNI(OP_CHDIR);
4222
4223         case KEY_close:
4224             UNI(OP_CLOSE);
4225
4226         case KEY_closedir:
4227             UNI(OP_CLOSEDIR);
4228
4229         case KEY_cmp:
4230             Eop(OP_SCMP);
4231
4232         case KEY_caller:
4233             UNI(OP_CALLER);
4234
4235         case KEY_crypt:
4236 #ifdef FCRYPT
4237             if (!PL_cryptseen) {
4238                 PL_cryptseen = TRUE;
4239                 init_des();
4240             }
4241 #endif
4242             LOP(OP_CRYPT,XTERM);
4243
4244         case KEY_chmod:
4245             LOP(OP_CHMOD,XTERM);
4246
4247         case KEY_chown:
4248             LOP(OP_CHOWN,XTERM);
4249
4250         case KEY_connect:
4251             LOP(OP_CONNECT,XTERM);
4252
4253         case KEY_chr:
4254             UNI(OP_CHR);
4255
4256         case KEY_cos:
4257             UNI(OP_COS);
4258
4259         case KEY_chroot:
4260             UNI(OP_CHROOT);
4261
4262         case KEY_do:
4263             s = skipspace(s);
4264             if (*s == '{')
4265                 PRETERMBLOCK(DO);
4266             if (*s != '\'')
4267                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4268             OPERATOR(DO);
4269
4270         case KEY_die:
4271             PL_hints |= HINT_BLOCK_SCOPE;
4272             LOP(OP_DIE,XTERM);
4273
4274         case KEY_defined:
4275             UNI(OP_DEFINED);
4276
4277         case KEY_delete:
4278             UNI(OP_DELETE);
4279
4280         case KEY_dbmopen:
4281             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4282             LOP(OP_DBMOPEN,XTERM);
4283
4284         case KEY_dbmclose:
4285             UNI(OP_DBMCLOSE);
4286
4287         case KEY_dump:
4288             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4289             LOOPX(OP_DUMP);
4290
4291         case KEY_else:
4292             PREBLOCK(ELSE);
4293
4294         case KEY_elsif:
4295             yylval.ival = CopLINE(PL_curcop);
4296             OPERATOR(ELSIF);
4297
4298         case KEY_eq:
4299             Eop(OP_SEQ);
4300
4301         case KEY_exists:
4302             UNI(OP_EXISTS);
4303         
4304         case KEY_exit:
4305             UNI(OP_EXIT);
4306
4307         case KEY_eval:
4308             s = skipspace(s);
4309             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4310             UNIBRACK(OP_ENTEREVAL);
4311
4312         case KEY_eof:
4313             UNI(OP_EOF);
4314
4315         case KEY_exp:
4316             UNI(OP_EXP);
4317
4318         case KEY_each:
4319             UNI(OP_EACH);
4320
4321         case KEY_exec:
4322             set_csh();
4323             LOP(OP_EXEC,XREF);
4324
4325         case KEY_endhostent:
4326             FUN0(OP_EHOSTENT);
4327
4328         case KEY_endnetent:
4329             FUN0(OP_ENETENT);
4330
4331         case KEY_endservent:
4332             FUN0(OP_ESERVENT);
4333
4334         case KEY_endprotoent:
4335             FUN0(OP_EPROTOENT);
4336
4337         case KEY_endpwent:
4338             FUN0(OP_EPWENT);
4339
4340         case KEY_endgrent:
4341             FUN0(OP_EGRENT);
4342
4343         case KEY_for:
4344         case KEY_foreach:
4345             yylval.ival = CopLINE(PL_curcop);
4346             s = skipspace(s);
4347             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4348                 char *p = s;
4349                 if ((PL_bufend - p) >= 3 &&
4350                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4351                     p += 2;
4352                 else if ((PL_bufend - p) >= 4 &&
4353                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4354                     p += 3;
4355                 p = skipspace(p);
4356                 if (isIDFIRST_lazy_if(p,UTF)) {
4357                     p = scan_ident(p, PL_bufend,
4358                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4359                     p = skipspace(p);
4360                 }