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