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