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