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