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