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