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