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