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