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