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