This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate with Sarathy.
[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) && isALPHA(*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 (len > e - s + 4) {
1483                         char *odest = SvPVX(sv);
1484
1485                         SvGROW(sv, (SvCUR(sv) + len - (e - s + 4)));
1486                         d = SvPVX(sv) + (d - odest);
1487                     }
1488                     Copy(str, d, len, char);
1489                     d += len;
1490                     SvREFCNT_dec(res);
1491                   cont_scan:
1492                     s = e + 1;
1493                 }
1494                 else
1495                     yyerror("Missing braces on \\N{}");
1496                 continue;
1497
1498             /* \c is a control character */
1499             case 'c':
1500                 s++;
1501 #ifdef EBCDIC
1502                 *d = *s++;
1503                 if (isLOWER(*d))
1504                    *d = toUPPER(*d);
1505                 *d++ = toCTRL(*d); 
1506 #else
1507                 len = *s++;
1508                 *d++ = toCTRL(len);
1509 #endif
1510                 continue;
1511
1512             /* printf-style backslashes, formfeeds, newlines, etc */
1513             case 'b':
1514                 *d++ = '\b';
1515                 break;
1516             case 'n':
1517                 *d++ = '\n';
1518                 break;
1519             case 'r':
1520                 *d++ = '\r';
1521                 break;
1522             case 'f':
1523                 *d++ = '\f';
1524                 break;
1525             case 't':
1526                 *d++ = '\t';
1527                 break;
1528 #ifdef EBCDIC
1529             case 'e':
1530                 *d++ = '\047';  /* CP 1047 */
1531                 break;
1532             case 'a':
1533                 *d++ = '\057';  /* CP 1047 */
1534                 break;
1535 #else
1536             case 'e':
1537                 *d++ = '\033';
1538                 break;
1539             case 'a':
1540                 *d++ = '\007';
1541                 break;
1542 #endif
1543             } /* end switch */
1544
1545             s++;
1546             continue;
1547         } /* end if (backslash) */
1548
1549         *d++ = *s++;
1550     } /* while loop to process each character */
1551
1552     /* terminate the string and set up the sv */
1553     *d = '\0';
1554     SvCUR_set(sv, d - SvPVX(sv));
1555     SvPOK_on(sv);
1556     if (has_utf)
1557         SvUTF8_on(sv);
1558
1559     /* shrink the sv if we allocated more than we used */
1560     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1561         SvLEN_set(sv, SvCUR(sv) + 1);
1562         Renew(SvPVX(sv), SvLEN(sv), char);
1563     }
1564
1565     /* return the substring (via yylval) only if we parsed anything */
1566     if (s > PL_bufptr) {
1567         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1568             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"), 
1569                               sv, Nullsv,
1570                               ( PL_lex_inwhat == OP_TRANS 
1571                                 ? "tr"
1572                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1573                                     ? "s"
1574                                     : "qq")));
1575         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1576     } else
1577         SvREFCNT_dec(sv);
1578     return s;
1579 }
1580
1581 /* S_intuit_more
1582  * Returns TRUE if there's more to the expression (e.g., a subscript),
1583  * FALSE otherwise.
1584  *
1585  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1586  *
1587  * ->[ and ->{ return TRUE
1588  * { and [ outside a pattern are always subscripts, so return TRUE
1589  * if we're outside a pattern and it's not { or [, then return FALSE
1590  * if we're in a pattern and the first char is a {
1591  *   {4,5} (any digits around the comma) returns FALSE
1592  * if we're in a pattern and the first char is a [
1593  *   [] returns FALSE
1594  *   [SOMETHING] has a funky algorithm to decide whether it's a
1595  *      character class or not.  It has to deal with things like
1596  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1597  * anything else returns TRUE
1598  */
1599
1600 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1601
1602 STATIC int
1603 S_intuit_more(pTHX_ register char *s)
1604 {
1605     if (PL_lex_brackets)
1606         return TRUE;
1607     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1608         return TRUE;
1609     if (*s != '{' && *s != '[')
1610         return FALSE;
1611     if (!PL_lex_inpat)
1612         return TRUE;
1613
1614     /* In a pattern, so maybe we have {n,m}. */
1615     if (*s == '{') {
1616         s++;
1617         if (!isDIGIT(*s))
1618             return TRUE;
1619         while (isDIGIT(*s))
1620             s++;
1621         if (*s == ',')
1622             s++;
1623         while (isDIGIT(*s))
1624             s++;
1625         if (*s == '}')
1626             return FALSE;
1627         return TRUE;
1628         
1629     }
1630
1631     /* On the other hand, maybe we have a character class */
1632
1633     s++;
1634     if (*s == ']' || *s == '^')
1635         return FALSE;
1636     else {
1637         /* this is terrifying, and it works */
1638         int weight = 2;         /* let's weigh the evidence */
1639         char seen[256];
1640         unsigned char un_char = 255, last_un_char;
1641         char *send = strchr(s,']');
1642         char tmpbuf[sizeof PL_tokenbuf * 4];
1643
1644         if (!send)              /* has to be an expression */
1645             return TRUE;
1646
1647         Zero(seen,256,char);
1648         if (*s == '$')
1649             weight -= 3;
1650         else if (isDIGIT(*s)) {
1651             if (s[1] != ']') {
1652                 if (isDIGIT(s[1]) && s[2] == ']')
1653                     weight -= 10;
1654             }
1655             else
1656                 weight -= 100;
1657         }
1658         for (; s < send; s++) {
1659             last_un_char = un_char;
1660             un_char = (unsigned char)*s;
1661             switch (*s) {
1662             case '@':
1663             case '&':
1664             case '$':
1665                 weight -= seen[un_char] * 10;
1666                 if (isALNUM_lazy_if(s+1,UTF)) {
1667                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1668                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1669                         weight -= 100;
1670                     else
1671                         weight -= 10;
1672                 }
1673                 else if (*s == '$' && s[1] &&
1674                   strchr("[#!%*<>()-=",s[1])) {
1675                     if (/*{*/ strchr("])} =",s[2]))
1676                         weight -= 10;
1677                     else
1678                         weight -= 1;
1679                 }
1680                 break;
1681             case '\\':
1682                 un_char = 254;
1683                 if (s[1]) {
1684                     if (strchr("wds]",s[1]))
1685                         weight += 100;
1686                     else if (seen['\''] || seen['"'])
1687                         weight += 1;
1688                     else if (strchr("rnftbxcav",s[1]))
1689                         weight += 40;
1690                     else if (isDIGIT(s[1])) {
1691                         weight += 40;
1692                         while (s[1] && isDIGIT(s[1]))
1693                             s++;
1694                     }
1695                 }
1696                 else
1697                     weight += 100;
1698                 break;
1699             case '-':
1700                 if (s[1] == '\\')
1701                     weight += 50;
1702                 if (strchr("aA01! ",last_un_char))
1703                     weight += 30;
1704                 if (strchr("zZ79~",s[1]))
1705                     weight += 30;
1706                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1707                     weight -= 5;        /* cope with negative subscript */
1708                 break;
1709             default:
1710                 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1711                         isALPHA(*s) && s[1] && isALPHA(s[1])) {
1712                     char *d = tmpbuf;
1713                     while (isALPHA(*s))
1714                         *d++ = *s++;
1715                     *d = '\0';
1716                     if (keyword(tmpbuf, d - tmpbuf))
1717                         weight -= 150;
1718                 }
1719                 if (un_char == last_un_char + 1)
1720                     weight += 5;
1721                 weight -= seen[un_char];
1722                 break;
1723             }
1724             seen[un_char]++;
1725         }
1726         if (weight >= 0)        /* probably a character class */
1727             return FALSE;
1728     }
1729
1730     return TRUE;
1731 }
1732
1733 /*
1734  * S_intuit_method
1735  *
1736  * Does all the checking to disambiguate
1737  *   foo bar
1738  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
1739  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1740  *
1741  * First argument is the stuff after the first token, e.g. "bar".
1742  *
1743  * Not a method if bar is a filehandle.
1744  * Not a method if foo is a subroutine prototyped to take a filehandle.
1745  * Not a method if it's really "Foo $bar"
1746  * Method if it's "foo $bar"
1747  * Not a method if it's really "print foo $bar"
1748  * Method if it's really "foo package::" (interpreted as package->foo)
1749  * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1750  * Not a method if bar is a filehandle or package, but is quoted with
1751  *   =>
1752  */
1753
1754 STATIC int
1755 S_intuit_method(pTHX_ char *start, GV *gv)
1756 {
1757     char *s = start + (*start == '$');
1758     char tmpbuf[sizeof PL_tokenbuf];
1759     STRLEN len;
1760     GV* indirgv;
1761
1762     if (gv) {
1763         CV *cv;
1764         if (GvIO(gv))
1765             return 0;
1766         if ((cv = GvCVu(gv))) {
1767             char *proto = SvPVX(cv);
1768             if (proto) {
1769                 if (*proto == ';')
1770                     proto++;
1771                 if (*proto == '*')
1772                     return 0;
1773             }
1774         } else
1775             gv = 0;
1776     }
1777     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1778     /* start is the beginning of the possible filehandle/object,
1779      * and s is the end of it
1780      * tmpbuf is a copy of it
1781      */
1782
1783     if (*start == '$') {
1784         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1785             return 0;
1786         s = skipspace(s);
1787         PL_bufptr = start;
1788         PL_expect = XREF;
1789         return *s == '(' ? FUNCMETH : METHOD;
1790     }
1791     if (!keyword(tmpbuf, len)) {
1792         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1793             len -= 2;
1794             tmpbuf[len] = '\0';
1795             goto bare_package;
1796         }
1797         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1798         if (indirgv && GvCVu(indirgv))
1799             return 0;
1800         /* filehandle or package name makes it a method */
1801         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1802             s = skipspace(s);
1803             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1804                 return 0;       /* no assumptions -- "=>" quotes bearword */
1805       bare_package:
1806             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1807                                                    newSVpvn(tmpbuf,len));
1808             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1809             PL_expect = XTERM;
1810             force_next(WORD);
1811             PL_bufptr = s;
1812             return *s == '(' ? FUNCMETH : METHOD;
1813         }
1814     }
1815     return 0;
1816 }
1817
1818 /*
1819  * S_incl_perldb
1820  * Return a string of Perl code to load the debugger.  If PERL5DB
1821  * is set, it will return the contents of that, otherwise a
1822  * compile-time require of perl5db.pl.
1823  */
1824
1825 STATIC char*
1826 S_incl_perldb(pTHX)
1827 {
1828     if (PL_perldb) {
1829         char *pdb = PerlEnv_getenv("PERL5DB");
1830
1831         if (pdb)
1832             return pdb;
1833         SETERRNO(0,SS$_NORMAL);
1834         return "BEGIN { require 'perl5db.pl' }";
1835     }
1836     return "";
1837 }
1838
1839
1840 /* Encoded script support. filter_add() effectively inserts a
1841  * 'pre-processing' function into the current source input stream. 
1842  * Note that the filter function only applies to the current source file
1843  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1844  *
1845  * The datasv parameter (which may be NULL) can be used to pass
1846  * private data to this instance of the filter. The filter function
1847  * can recover the SV using the FILTER_DATA macro and use it to
1848  * store private buffers and state information.
1849  *
1850  * The supplied datasv parameter is upgraded to a PVIO type
1851  * and the IoDIRP field is used to store the function pointer,
1852  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1853  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1854  * private use must be set using malloc'd pointers.
1855  */
1856
1857 SV *
1858 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1859 {
1860     if (!funcp)
1861         return Nullsv;
1862
1863     if (!PL_rsfp_filters)
1864         PL_rsfp_filters = newAV();
1865     if (!datasv)
1866         datasv = NEWSV(255,0);
1867     if (!SvUPGRADE(datasv, SVt_PVIO))
1868         Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1869     IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1870     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1871     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1872                           funcp, SvPV_nolen(datasv)));
1873     av_unshift(PL_rsfp_filters, 1);
1874     av_store(PL_rsfp_filters, 0, datasv) ;
1875     return(datasv);
1876 }
1877  
1878
1879 /* Delete most recently added instance of this filter function. */
1880 void
1881 Perl_filter_del(pTHX_ filter_t funcp)
1882 {
1883     SV *datasv;
1884     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1885     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1886         return;
1887     /* if filter is on top of stack (usual case) just pop it off */
1888     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1889     if (IoDIRP(datasv) == (DIR*)funcp) {
1890         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1891         IoDIRP(datasv) = (DIR*)NULL;
1892         sv_free(av_pop(PL_rsfp_filters));
1893
1894         return;
1895     }
1896     /* we need to search for the correct entry and clear it     */
1897     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1898 }
1899
1900
1901 /* Invoke the n'th filter function for the current rsfp.         */
1902 I32
1903 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1904             
1905                
1906                         /* 0 = read one text line */
1907 {
1908     filter_t funcp;
1909     SV *datasv = NULL;
1910
1911     if (!PL_rsfp_filters)
1912         return -1;
1913     if (idx > AvFILLp(PL_rsfp_filters)){       /* Any more filters?     */
1914         /* Provide a default input filter to make life easy.    */
1915         /* Note that we append to the line. This is handy.      */
1916         DEBUG_P(PerlIO_printf(Perl_debug_log,
1917                               "filter_read %d: from rsfp\n", idx));
1918         if (maxlen) { 
1919             /* Want a block */
1920             int len ;
1921             int old_len = SvCUR(buf_sv) ;
1922
1923             /* ensure buf_sv is large enough */
1924             SvGROW(buf_sv, old_len + maxlen) ;
1925             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1926                 if (PerlIO_error(PL_rsfp))
1927                     return -1;          /* error */
1928                 else
1929                     return 0 ;          /* end of file */
1930             }
1931             SvCUR_set(buf_sv, old_len + len) ;
1932         } else {
1933             /* Want a line */
1934             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1935                 if (PerlIO_error(PL_rsfp))
1936                     return -1;          /* error */
1937                 else
1938                     return 0 ;          /* end of file */
1939             }
1940         }
1941         return SvCUR(buf_sv);
1942     }
1943     /* Skip this filter slot if filter has been deleted */
1944     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1945         DEBUG_P(PerlIO_printf(Perl_debug_log,
1946                               "filter_read %d: skipped (filter deleted)\n",
1947                               idx));
1948         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1949     }
1950     /* Get function pointer hidden within datasv        */
1951     funcp = (filter_t)IoDIRP(datasv);
1952     DEBUG_P(PerlIO_printf(Perl_debug_log,
1953                           "filter_read %d: via function %p (%s)\n",
1954                           idx, funcp, SvPV_nolen(datasv)));
1955     /* Call function. The function is expected to       */
1956     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
1957     /* Return: <0:error, =0:eof, >0:not eof             */
1958     return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1959 }
1960
1961 STATIC char *
1962 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1963 {
1964 #ifdef PERL_CR_FILTER
1965     if (!PL_rsfp_filters) {
1966         filter_add(S_cr_textfilter,NULL);
1967     }
1968 #endif
1969     if (PL_rsfp_filters) {
1970
1971         if (!append)
1972             SvCUR_set(sv, 0);   /* start with empty line        */
1973         if (FILTER_READ(0, sv, 0) > 0)
1974             return ( SvPVX(sv) ) ;
1975         else
1976             return Nullch ;
1977     }
1978     else
1979         return (sv_gets(sv, fp, append));
1980 }
1981
1982
1983 #ifdef DEBUGGING
1984     static char* exp_name[] =
1985         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
1986           "ATTRTERM", "TERMBLOCK"
1987         };
1988 #endif
1989
1990 /*
1991   yylex
1992
1993   Works out what to call the token just pulled out of the input
1994   stream.  The yacc parser takes care of taking the ops we return and
1995   stitching them into a tree.
1996
1997   Returns:
1998     PRIVATEREF
1999
2000   Structure:
2001       if read an identifier
2002           if we're in a my declaration
2003               croak if they tried to say my($foo::bar)
2004               build the ops for a my() declaration
2005           if it's an access to a my() variable
2006               are we in a sort block?
2007                   croak if my($a); $a <=> $b
2008               build ops for access to a my() variable
2009           if in a dq string, and they've said @foo and we can't find @foo
2010               croak
2011           build ops for a bareword
2012       if we already built the token before, use it.
2013 */
2014
2015 int
2016 #ifdef USE_PURE_BISON
2017 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
2018 #else
2019 Perl_yylex(pTHX)
2020 #endif
2021 {
2022     dTHR;
2023     register char *s;
2024     register char *d;
2025     register I32 tmp;
2026     STRLEN len;
2027     GV *gv = Nullgv;
2028     GV **gvp = 0;
2029
2030 #ifdef USE_PURE_BISON
2031     yylval_pointer = lvalp;
2032     yychar_pointer = lcharp;
2033 #endif
2034
2035     /* check if there's an identifier for us to look at */
2036     if (PL_pending_ident) {
2037         /* pit holds the identifier we read and pending_ident is reset */
2038         char pit = PL_pending_ident;
2039         PL_pending_ident = 0;
2040
2041         /* if we're in a my(), we can't allow dynamics here.
2042            $foo'bar has already been turned into $foo::bar, so
2043            just check for colons.
2044
2045            if it's a legal name, the OP is a PADANY.
2046         */
2047         if (PL_in_my) {
2048             if (PL_in_my == KEY_our) {  /* "our" is merely analogous to "my" */
2049                 if (strchr(PL_tokenbuf,':'))
2050                     yyerror(Perl_form(aTHX_ "No package name allowed for "
2051                                       "variable %s in \"our\"",
2052                                       PL_tokenbuf));
2053                 tmp = pad_allocmy(PL_tokenbuf);
2054             }
2055             else {
2056                 if (strchr(PL_tokenbuf,':'))
2057                     yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
2058
2059                 yylval.opval = newOP(OP_PADANY, 0);
2060                 yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
2061                 return PRIVATEREF;
2062             }
2063         }
2064
2065         /* 
2066            build the ops for accesses to a my() variable.
2067
2068            Deny my($a) or my($b) in a sort block, *if* $a or $b is
2069            then used in a comparison.  This catches most, but not
2070            all cases.  For instance, it catches
2071                sort { my($a); $a <=> $b }
2072            but not
2073                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
2074            (although why you'd do that is anyone's guess).
2075         */
2076
2077         if (!strchr(PL_tokenbuf,':')) {
2078 #ifdef USE_THREADS
2079             /* Check for single character per-thread SVs */
2080             if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
2081                 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
2082                 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
2083             {
2084                 yylval.opval = newOP(OP_THREADSV, 0);
2085                 yylval.opval->op_targ = tmp;
2086                 return PRIVATEREF;
2087             }
2088 #endif /* USE_THREADS */
2089             if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
2090                 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
2091                 /* might be an "our" variable" */
2092                 if (SvFLAGS(namesv) & SVpad_OUR) {
2093                     /* build ops for a bareword */
2094                     SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
2095                     sv_catpvn(sym, "::", 2);
2096                     sv_catpv(sym, PL_tokenbuf+1);
2097                     yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
2098                     yylval.opval->op_private = OPpCONST_ENTERED;
2099                     gv_fetchpv(SvPVX(sym),
2100                         (PL_in_eval
2101                             ? (GV_ADDMULTI | GV_ADDINEVAL)
2102                             : TRUE
2103                         ),
2104                         ((PL_tokenbuf[0] == '$') ? SVt_PV
2105                          : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2106                          : SVt_PVHV));
2107                     return WORD;
2108                 }
2109
2110                 /* if it's a sort block and they're naming $a or $b */
2111                 if (PL_last_lop_op == OP_SORT &&
2112                     PL_tokenbuf[0] == '$' &&
2113                     (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
2114                     && !PL_tokenbuf[2])
2115                 {
2116                     for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
2117                          d < PL_bufend && *d != '\n';
2118                          d++)
2119                     {
2120                         if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
2121                             Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
2122                                   PL_tokenbuf);
2123                         }
2124                     }
2125                 }
2126
2127                 yylval.opval = newOP(OP_PADANY, 0);
2128                 yylval.opval->op_targ = tmp;
2129                 return PRIVATEREF;
2130             }
2131         }
2132
2133         /*
2134            Whine if they've said @foo in a doublequoted string,
2135            and @foo isn't a variable we can find in the symbol
2136            table.
2137         */
2138         if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
2139             GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
2140             if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
2141                 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
2142                              PL_tokenbuf, PL_tokenbuf));
2143         }
2144
2145         /* build ops for a bareword */
2146         yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
2147         yylval.opval->op_private = OPpCONST_ENTERED;
2148         gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
2149                    ((PL_tokenbuf[0] == '$') ? SVt_PV
2150                     : (PL_tokenbuf[0] == '@') ? SVt_PVAV
2151                     : SVt_PVHV));
2152         return WORD;
2153     }
2154
2155     /* no identifier pending identification */
2156
2157     switch (PL_lex_state) {
2158 #ifdef COMMENTARY
2159     case LEX_NORMAL:            /* Some compilers will produce faster */
2160     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2161         break;
2162 #endif
2163
2164     /* when we've already built the next token, just pull it out of the queue */
2165     case LEX_KNOWNEXT:
2166         PL_nexttoke--;
2167         yylval = PL_nextval[PL_nexttoke];
2168         if (!PL_nexttoke) {
2169             PL_lex_state = PL_lex_defer;
2170             PL_expect = PL_lex_expect;
2171             PL_lex_defer = LEX_NORMAL;
2172         }
2173         return(PL_nexttype[PL_nexttoke]);
2174
2175     /* interpolated case modifiers like \L \U, including \Q and \E.
2176        when we get here, PL_bufptr is at the \
2177     */
2178     case LEX_INTERPCASEMOD:
2179 #ifdef DEBUGGING
2180         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2181             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2182 #endif
2183         /* handle \E or end of string */
2184         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2185             char oldmod;
2186
2187             /* if at a \E */
2188             if (PL_lex_casemods) {
2189                 oldmod = PL_lex_casestack[--PL_lex_casemods];
2190                 PL_lex_casestack[PL_lex_casemods] = '\0';
2191
2192                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2193                     PL_bufptr += 2;
2194                     PL_lex_state = LEX_INTERPCONCAT;
2195                 }
2196                 return ')';
2197             }
2198             if (PL_bufptr != PL_bufend)
2199                 PL_bufptr += 2;
2200             PL_lex_state = LEX_INTERPCONCAT;
2201             return yylex();
2202         }
2203         else {
2204             s = PL_bufptr + 1;
2205             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2206                 tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
2207             if (strchr("LU", *s) &&
2208                 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2209             {
2210                 PL_lex_casestack[--PL_lex_casemods] = '\0';
2211                 return ')';
2212             }
2213             if (PL_lex_casemods > 10) {
2214                 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2215                 if (newlb != PL_lex_casestack) {
2216                     SAVEFREEPV(newlb);
2217                     PL_lex_casestack = newlb;
2218                 }
2219             }
2220             PL_lex_casestack[PL_lex_casemods++] = *s;
2221             PL_lex_casestack[PL_lex_casemods] = '\0';
2222             PL_lex_state = LEX_INTERPCONCAT;
2223             PL_nextval[PL_nexttoke].ival = 0;
2224             force_next('(');
2225             if (*s == 'l')
2226                 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2227             else if (*s == 'u')
2228                 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2229             else if (*s == 'L')
2230                 PL_nextval[PL_nexttoke].ival = OP_LC;
2231             else if (*s == 'U')
2232                 PL_nextval[PL_nexttoke].ival = OP_UC;
2233             else if (*s == 'Q')
2234                 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2235             else
2236                 Perl_croak(aTHX_ "panic: yylex");
2237             PL_bufptr = s + 1;
2238             force_next(FUNC);
2239             if (PL_lex_starts) {
2240                 s = PL_bufptr;
2241                 PL_lex_starts = 0;
2242                 Aop(OP_CONCAT);
2243             }
2244             else
2245                 return yylex();
2246         }
2247
2248     case LEX_INTERPPUSH:
2249         return sublex_push();
2250
2251     case LEX_INTERPSTART:
2252         if (PL_bufptr == PL_bufend)
2253             return sublex_done();
2254         PL_expect = XTERM;
2255         PL_lex_dojoin = (*PL_bufptr == '@');
2256         PL_lex_state = LEX_INTERPNORMAL;
2257         if (PL_lex_dojoin) {
2258             PL_nextval[PL_nexttoke].ival = 0;
2259             force_next(',');
2260 #ifdef USE_THREADS
2261             PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2262             PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2263             force_next(PRIVATEREF);
2264 #else
2265             force_ident("\"", '$');
2266 #endif /* USE_THREADS */
2267             PL_nextval[PL_nexttoke].ival = 0;
2268             force_next('$');
2269             PL_nextval[PL_nexttoke].ival = 0;
2270             force_next('(');
2271             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2272             force_next(FUNC);
2273         }
2274         if (PL_lex_starts++) {
2275             s = PL_bufptr;
2276             Aop(OP_CONCAT);
2277         }
2278         return yylex();
2279
2280     case LEX_INTERPENDMAYBE:
2281         if (intuit_more(PL_bufptr)) {
2282             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2283             break;
2284         }
2285         /* FALL THROUGH */
2286
2287     case LEX_INTERPEND:
2288         if (PL_lex_dojoin) {
2289             PL_lex_dojoin = FALSE;
2290             PL_lex_state = LEX_INTERPCONCAT;
2291             return ')';
2292         }
2293         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2294             && SvEVALED(PL_lex_repl))
2295         {
2296             if (PL_bufptr != PL_bufend)
2297                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2298             PL_lex_repl = Nullsv;
2299         }
2300         /* FALLTHROUGH */
2301     case LEX_INTERPCONCAT:
2302 #ifdef DEBUGGING
2303         if (PL_lex_brackets)
2304             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2305 #endif
2306         if (PL_bufptr == PL_bufend)
2307             return sublex_done();
2308
2309         if (SvIVX(PL_linestr) == '\'') {
2310             SV *sv = newSVsv(PL_linestr);
2311             if (!PL_lex_inpat)
2312                 sv = tokeq(sv);
2313             else if ( PL_hints & HINT_NEW_RE )
2314                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2315             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2316             s = PL_bufend;
2317         }
2318         else {
2319             s = scan_const(PL_bufptr);
2320             if (*s == '\\')
2321                 PL_lex_state = LEX_INTERPCASEMOD;
2322             else
2323                 PL_lex_state = LEX_INTERPSTART;
2324         }
2325
2326         if (s != PL_bufptr) {
2327             PL_nextval[PL_nexttoke] = yylval;
2328             PL_expect = XTERM;
2329             force_next(THING);
2330             if (PL_lex_starts++)
2331                 Aop(OP_CONCAT);
2332             else {
2333                 PL_bufptr = s;
2334                 return yylex();
2335             }
2336         }
2337
2338         return yylex();
2339     case LEX_FORMLINE:
2340         PL_lex_state = LEX_NORMAL;
2341         s = scan_formline(PL_bufptr);
2342         if (!PL_lex_formbrack)
2343             goto rightbracket;
2344         OPERATOR(';');
2345     }
2346
2347     s = PL_bufptr;
2348     PL_oldoldbufptr = PL_oldbufptr;
2349     PL_oldbufptr = s;
2350     DEBUG_p( {
2351         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2352                       exp_name[PL_expect], s);
2353     } )
2354
2355   retry:
2356     switch (*s) {
2357     default:
2358         if (isIDFIRST_lazy_if(s,UTF))
2359             goto keylookup;
2360         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2361     case 4:
2362     case 26:
2363         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2364     case 0:
2365         if (!PL_rsfp) {
2366             PL_last_uni = 0;
2367             PL_last_lop = 0;
2368             if (PL_lex_brackets)
2369                 yyerror("Missing right curly or square bracket");
2370             TOKEN(0);
2371         }
2372         if (s++ < PL_bufend)
2373             goto retry;                 /* ignore stray nulls */
2374         PL_last_uni = 0;
2375         PL_last_lop = 0;
2376         if (!PL_in_eval && !PL_preambled) {
2377             PL_preambled = TRUE;
2378             sv_setpv(PL_linestr,incl_perldb());
2379             if (SvCUR(PL_linestr))
2380                 sv_catpv(PL_linestr,";");
2381             if (PL_preambleav){
2382                 while(AvFILLp(PL_preambleav) >= 0) {
2383                     SV *tmpsv = av_shift(PL_preambleav);
2384                     sv_catsv(PL_linestr, tmpsv);
2385                     sv_catpv(PL_linestr, ";");
2386                     sv_free(tmpsv);
2387                 }
2388                 sv_free((SV*)PL_preambleav);
2389                 PL_preambleav = NULL;
2390             }
2391             if (PL_minus_n || PL_minus_p) {
2392                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2393                 if (PL_minus_l)
2394                     sv_catpv(PL_linestr,"chomp;");
2395                 if (PL_minus_a) {
2396                     GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
2397                     if (gv)
2398                         GvIMPORTED_AV_on(gv);
2399                     if (PL_minus_F) {
2400                         if (strchr("/'\"", *PL_splitstr)
2401                               && strchr(PL_splitstr + 1, *PL_splitstr))
2402                             Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2403                         else {
2404                             char delim;
2405                             s = "'~#\200\1'"; /* surely one char is unused...*/
2406                             while (s[1] && strchr(PL_splitstr, *s))  s++;
2407                             delim = *s;
2408                             Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
2409                                       "q" + (delim == '\''), delim);
2410                             for (s = PL_splitstr; *s; s++) {
2411                                 if (*s == '\\')
2412                                     sv_catpvn(PL_linestr, "\\", 1);
2413                                 sv_catpvn(PL_linestr, s, 1);
2414                             }
2415                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2416                         }
2417                     }
2418                     else
2419                         sv_catpv(PL_linestr,"@F=split(' ');");
2420                 }
2421             }
2422             sv_catpv(PL_linestr, "\n");
2423             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2424             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2425             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2426                 SV *sv = NEWSV(85,0);
2427
2428                 sv_upgrade(sv, SVt_PVMG);
2429                 sv_setsv(sv,PL_linestr);
2430                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2431             }
2432             goto retry;
2433         }
2434         do {
2435             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2436               fake_eof:
2437                 if (PL_rsfp) {
2438                     if (PL_preprocess && !PL_in_eval)
2439                         (void)PerlProc_pclose(PL_rsfp);
2440                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2441                         PerlIO_clearerr(PL_rsfp);
2442                     else
2443                         (void)PerlIO_close(PL_rsfp);
2444                     PL_rsfp = Nullfp;
2445                     PL_doextract = FALSE;
2446                 }
2447                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2448                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2449                     sv_catpv(PL_linestr,";}");
2450                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2451                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2452                     PL_minus_n = PL_minus_p = 0;
2453                     goto retry;
2454                 }
2455                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2456                 sv_setpv(PL_linestr,"");
2457                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2458             }
2459             if (PL_doextract) {
2460                 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2461                     PL_doextract = FALSE;
2462
2463                 /* Incest with pod. */
2464                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2465                     sv_setpv(PL_linestr, "");
2466                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2467                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2468                     PL_doextract = FALSE;
2469                 }
2470             }
2471             incline(s);
2472         } while (PL_doextract);
2473         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2474         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2475             SV *sv = NEWSV(85,0);
2476
2477             sv_upgrade(sv, SVt_PVMG);
2478             sv_setsv(sv,PL_linestr);
2479             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2480         }
2481         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2482         if (CopLINE(PL_curcop) == 1) {
2483             while (s < PL_bufend && isSPACE(*s))
2484                 s++;
2485             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2486                 s++;
2487             d = Nullch;
2488             if (!PL_in_eval) {
2489                 if (*s == '#' && *(s+1) == '!')
2490                     d = s + 2;
2491 #ifdef ALTERNATE_SHEBANG
2492                 else {
2493                     static char as[] = ALTERNATE_SHEBANG;
2494                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2495                         d = s + (sizeof(as) - 1);
2496                 }
2497 #endif /* ALTERNATE_SHEBANG */
2498             }
2499             if (d) {
2500                 char *ipath;
2501                 char *ipathend;
2502
2503                 while (isSPACE(*d))
2504                     d++;
2505                 ipath = d;
2506                 while (*d && !isSPACE(*d))
2507                     d++;
2508                 ipathend = d;
2509
2510 #ifdef ARG_ZERO_IS_SCRIPT
2511                 if (ipathend > ipath) {
2512                     /*
2513                      * HP-UX (at least) sets argv[0] to the script name,
2514                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2515                      * at least, set argv[0] to the basename of the Perl
2516                      * interpreter. So, having found "#!", we'll set it right.
2517                      */
2518                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2519                     assert(SvPOK(x) || SvGMAGICAL(x));
2520                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2521                         sv_setpvn(x, ipath, ipathend - ipath);
2522                         SvSETMAGIC(x);
2523                     }
2524                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2525                 }
2526 #endif /* ARG_ZERO_IS_SCRIPT */
2527
2528                 /*
2529                  * Look for options.
2530                  */
2531                 d = instr(s,"perl -");
2532                 if (!d) {
2533                     d = instr(s,"perl");
2534 #if defined(DOSISH)
2535                     /* avoid getting into infinite loops when shebang
2536                      * line contains "Perl" rather than "perl" */
2537                     if (!d) {
2538                         for (d = ipathend-4; d >= ipath; --d) {
2539                             if ((*d == 'p' || *d == 'P')
2540                                 && !ibcmp(d, "perl", 4))
2541                             {
2542                                 break;
2543                             }
2544                         }
2545                         if (d < ipath)
2546                             d = Nullch;
2547                     }
2548 #endif
2549                 }
2550 #ifdef ALTERNATE_SHEBANG
2551                 /*
2552                  * If the ALTERNATE_SHEBANG on this system starts with a
2553                  * character that can be part of a Perl expression, then if
2554                  * we see it but not "perl", we're probably looking at the
2555                  * start of Perl code, not a request to hand off to some
2556                  * other interpreter.  Similarly, if "perl" is there, but
2557                  * not in the first 'word' of the line, we assume the line
2558                  * contains the start of the Perl program.
2559                  */
2560                 if (d && *s != '#') {
2561                     char *c = ipath;
2562                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2563                         c++;
2564                     if (c < d)
2565                         d = Nullch;     /* "perl" not in first word; ignore */
2566                     else
2567                         *s = '#';       /* Don't try to parse shebang line */
2568                 }
2569 #endif /* ALTERNATE_SHEBANG */
2570                 if (!d &&
2571                     *s == '#' &&
2572                     ipathend > ipath &&
2573                     !PL_minus_c &&
2574                     !instr(s,"indir") &&
2575                     instr(PL_origargv[0],"perl"))
2576                 {
2577                     char **newargv;
2578
2579                     *ipathend = '\0';
2580                     s = ipathend + 1;
2581                     while (s < PL_bufend && isSPACE(*s))
2582                         s++;
2583                     if (s < PL_bufend) {
2584                         Newz(899,newargv,PL_origargc+3,char*);
2585                         newargv[1] = s;
2586                         while (s < PL_bufend && !isSPACE(*s))
2587                             s++;
2588                         *s = '\0';
2589                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2590                     }
2591                     else
2592                         newargv = PL_origargv;
2593                     newargv[0] = ipath;
2594                     PerlProc_execv(ipath, newargv);
2595                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2596                 }
2597                 if (d) {
2598                     U32 oldpdb = PL_perldb;
2599                     bool oldn = PL_minus_n;
2600                     bool oldp = PL_minus_p;
2601
2602                     while (*d && !isSPACE(*d)) d++;
2603                     while (*d == ' ' || *d == '\t') d++;
2604
2605                     if (*d++ == '-') {
2606                         do {
2607                             if (*d == 'M' || *d == 'm') {
2608                                 char *m = d;
2609                                 while (*d && !isSPACE(*d)) d++;
2610                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2611                                       (int)(d - m), m);
2612                             }
2613                             d = moreswitches(d);
2614                         } while (d);
2615                         if ((PERLDB_LINE && !oldpdb) ||
2616                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2617                               /* if we have already added "LINE: while (<>) {",
2618                                  we must not do it again */
2619                         {
2620                             sv_setpv(PL_linestr, "");
2621                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2622                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2623                             PL_preambled = FALSE;
2624                             if (PERLDB_LINE)
2625                                 (void)gv_fetchfile(PL_origfilename);
2626                             goto retry;
2627                         }
2628                     }
2629                 }
2630             }
2631         }
2632         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2633             PL_bufptr = s;
2634             PL_lex_state = LEX_FORMLINE;
2635             return yylex();
2636         }
2637         goto retry;
2638     case '\r':
2639 #ifdef PERL_STRICT_CR
2640         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2641         Perl_croak(aTHX_ 
2642       "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2643 #endif
2644     case ' ': case '\t': case '\f': case 013:
2645         s++;
2646         goto retry;
2647     case '#':
2648     case '\n':
2649         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2650             d = PL_bufend;
2651             while (s < d && *s != '\n')
2652                 s++;
2653             if (s < d)
2654                 s++;
2655             incline(s);
2656             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2657                 PL_bufptr = s;
2658                 PL_lex_state = LEX_FORMLINE;
2659                 return yylex();
2660             }
2661         }
2662         else {
2663             *s = '\0';
2664             PL_bufend = s;
2665         }
2666         goto retry;
2667     case '-':
2668         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2669             s++;
2670             PL_bufptr = s;
2671             tmp = *s++;
2672
2673             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2674                 s++;
2675
2676             if (strnEQ(s,"=>",2)) {
2677                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2678                 OPERATOR('-');          /* unary minus */
2679             }
2680             PL_last_uni = PL_oldbufptr;
2681             PL_last_lop_op = OP_FTEREAD;        /* good enough */
2682             switch (tmp) {
2683             case 'r': FTST(OP_FTEREAD);
2684             case 'w': FTST(OP_FTEWRITE);
2685             case 'x': FTST(OP_FTEEXEC);
2686             case 'o': FTST(OP_FTEOWNED);
2687             case 'R': FTST(OP_FTRREAD);
2688             case 'W': FTST(OP_FTRWRITE);
2689             case 'X': FTST(OP_FTREXEC);
2690             case 'O': FTST(OP_FTROWNED);
2691             case 'e': FTST(OP_FTIS);
2692             case 'z': FTST(OP_FTZERO);
2693             case 's': FTST(OP_FTSIZE);
2694             case 'f': FTST(OP_FTFILE);
2695             case 'd': FTST(OP_FTDIR);
2696             case 'l': FTST(OP_FTLINK);
2697             case 'p': FTST(OP_FTPIPE);
2698             case 'S': FTST(OP_FTSOCK);
2699             case 'u': FTST(OP_FTSUID);
2700             case 'g': FTST(OP_FTSGID);
2701             case 'k': FTST(OP_FTSVTX);
2702             case 'b': FTST(OP_FTBLK);
2703             case 'c': FTST(OP_FTCHR);
2704             case 't': FTST(OP_FTTTY);
2705             case 'T': FTST(OP_FTTEXT);
2706             case 'B': FTST(OP_FTBINARY);
2707             case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2708             case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2709             case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2710             default:
2711                 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2712                 break;
2713             }
2714         }
2715         tmp = *s++;
2716         if (*s == tmp) {
2717             s++;
2718             if (PL_expect == XOPERATOR)
2719                 TERM(POSTDEC);
2720             else
2721                 OPERATOR(PREDEC);
2722         }
2723         else if (*s == '>') {
2724             s++;
2725             s = skipspace(s);
2726             if (isIDFIRST_lazy_if(s,UTF)) {
2727                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2728                 TOKEN(ARROW);
2729             }
2730             else if (*s == '$')
2731                 OPERATOR(ARROW);
2732             else
2733                 TERM(ARROW);
2734         }
2735         if (PL_expect == XOPERATOR)
2736             Aop(OP_SUBTRACT);
2737         else {
2738             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2739                 check_uni();
2740             OPERATOR('-');              /* unary minus */
2741         }
2742
2743     case '+':
2744         tmp = *s++;
2745         if (*s == tmp) {
2746             s++;
2747             if (PL_expect == XOPERATOR)
2748                 TERM(POSTINC);
2749             else
2750                 OPERATOR(PREINC);
2751         }
2752         if (PL_expect == XOPERATOR)
2753             Aop(OP_ADD);
2754         else {
2755             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2756                 check_uni();
2757             OPERATOR('+');
2758         }
2759
2760     case '*':
2761         if (PL_expect != XOPERATOR) {
2762             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2763             PL_expect = XOPERATOR;
2764             force_ident(PL_tokenbuf, '*');
2765             if (!*PL_tokenbuf)
2766                 PREREF('*');
2767             TERM('*');
2768         }
2769         s++;
2770         if (*s == '*') {
2771             s++;
2772             PWop(OP_POW);
2773         }
2774         Mop(OP_MULTIPLY);
2775
2776     case '%':
2777         if (PL_expect == XOPERATOR) {
2778             ++s;
2779             Mop(OP_MODULO);
2780         }
2781         PL_tokenbuf[0] = '%';
2782         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2783         if (!PL_tokenbuf[1]) {
2784             if (s == PL_bufend)
2785                 yyerror("Final % should be \\% or %name");
2786             PREREF('%');
2787         }
2788         PL_pending_ident = '%';
2789         TERM('%');
2790
2791     case '^':
2792         s++;
2793         BOop(OP_BIT_XOR);
2794     case '[':
2795         PL_lex_brackets++;
2796         /* FALL THROUGH */
2797     case '~':
2798     case ',':
2799         tmp = *s++;
2800         OPERATOR(tmp);
2801     case ':':
2802         if (s[1] == ':') {
2803             len = 0;
2804             goto just_a_word;
2805         }
2806         s++;
2807         switch (PL_expect) {
2808             OP *attrs;
2809         case XOPERATOR:
2810             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2811                 break;
2812             PL_bufptr = s;      /* update in case we back off */
2813             goto grabattrs;
2814         case XATTRBLOCK:
2815             PL_expect = XBLOCK;
2816             goto grabattrs;
2817         case XATTRTERM:
2818             PL_expect = XTERMBLOCK;
2819          grabattrs:
2820             s = skipspace(s);
2821             attrs = Nullop;
2822             while (isIDFIRST_lazy_if(s,UTF)) {
2823                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2824                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2825                     if (tmp < 0) tmp = -tmp;
2826                     switch (tmp) {
2827                     case KEY_or:
2828                     case KEY_and:
2829                     case KEY_for:
2830                     case KEY_unless:
2831                     case KEY_if:
2832                     case KEY_while:
2833                     case KEY_until:
2834                         goto got_attrs;
2835                     default:
2836                         break;
2837                     }
2838                 }
2839                 if (*d == '(') {
2840                     d = scan_str(d,TRUE,TRUE);
2841                     if (!d) {
2842                         if (PL_lex_stuff) {
2843                             SvREFCNT_dec(PL_lex_stuff);
2844                             PL_lex_stuff = Nullsv;
2845                         }
2846                         /* MUST advance bufptr here to avoid bogus
2847                            "at end of line" context messages from yyerror().
2848                          */
2849                         PL_bufptr = s + len;
2850                         yyerror("Unterminated attribute parameter in attribute list");
2851                         if (attrs)
2852                             op_free(attrs);
2853                         return 0;       /* EOF indicator */
2854                     }
2855                 }
2856                 if (PL_lex_stuff) {
2857                     SV *sv = newSVpvn(s, len);
2858                     sv_catsv(sv, PL_lex_stuff);
2859                     attrs = append_elem(OP_LIST, attrs,
2860                                         newSVOP(OP_CONST, 0, sv));
2861                     SvREFCNT_dec(PL_lex_stuff);
2862                     PL_lex_stuff = Nullsv;
2863                 }
2864                 else {
2865                     attrs = append_elem(OP_LIST, attrs,
2866                                         newSVOP(OP_CONST, 0,
2867                                                 newSVpvn(s, len)));
2868                 }
2869                 s = skipspace(d);
2870                 if (*s == ':' && s[1] != ':')
2871                     s = skipspace(s+1);
2872                 else if (s == d)
2873                     break;      /* require real whitespace or :'s */
2874             }
2875             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2876             if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
2877                 char q = ((*s == '\'') ? '"' : '\'');
2878                 /* If here for an expression, and parsed no attrs, back off. */
2879                 if (tmp == '=' && !attrs) {
2880                     s = PL_bufptr;
2881                     break;
2882                 }
2883                 /* MUST advance bufptr here to avoid bogus "at end of line"
2884                    context messages from yyerror().
2885                  */
2886                 PL_bufptr = s;
2887                 if (!*s)
2888                     yyerror("Unterminated attribute list");
2889                 else
2890                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
2891                                       q, *s, q));
2892                 if (attrs)
2893                     op_free(attrs);
2894                 OPERATOR(':');
2895             }
2896         got_attrs:
2897             if (attrs) {
2898                 PL_nextval[PL_nexttoke].opval = attrs;
2899                 force_next(THING);
2900             }
2901             TOKEN(COLONATTR);
2902         }
2903         OPERATOR(':');
2904     case '(':
2905         s++;
2906         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2907             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
2908         else
2909             PL_expect = XTERM;
2910         TOKEN('(');
2911     case ';':
2912         if (CopLINE(PL_curcop) < PL_copline)
2913             PL_copline = CopLINE(PL_curcop);
2914         tmp = *s++;
2915         OPERATOR(tmp);
2916     case ')':
2917         tmp = *s++;
2918         s = skipspace(s);
2919         if (*s == '{')
2920             PREBLOCK(tmp);
2921         TERM(tmp);
2922     case ']':
2923         s++;
2924         if (PL_lex_brackets <= 0)
2925             yyerror("Unmatched right square bracket");
2926         else
2927             --PL_lex_brackets;
2928         if (PL_lex_state == LEX_INTERPNORMAL) {
2929             if (PL_lex_brackets == 0) {
2930                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2931                     PL_lex_state = LEX_INTERPEND;
2932             }
2933         }
2934         TERM(']');
2935     case '{':
2936       leftbracket:
2937         s++;
2938         if (PL_lex_brackets > 100) {
2939             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2940             if (newlb != PL_lex_brackstack) {
2941                 SAVEFREEPV(newlb);
2942                 PL_lex_brackstack = newlb;
2943             }
2944         }
2945         switch (PL_expect) {
2946         case XTERM:
2947             if (PL_lex_formbrack) {
2948                 s--;
2949                 PRETERMBLOCK(DO);
2950             }
2951             if (PL_oldoldbufptr == PL_last_lop)
2952                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2953             else
2954                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2955             OPERATOR(HASHBRACK);
2956         case XOPERATOR:
2957             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2958                 s++;
2959             d = s;
2960             PL_tokenbuf[0] = '\0';
2961             if (d < PL_bufend && *d == '-') {
2962                 PL_tokenbuf[0] = '-';
2963                 d++;
2964                 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2965                     d++;
2966             }
2967             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
2968                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2969                               FALSE, &len);
2970                 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2971                     d++;
2972                 if (*d == '}') {
2973                     char minus = (PL_tokenbuf[0] == '-');
2974                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2975                     if (minus)
2976                         force_next('-');
2977                 }
2978             }
2979             /* FALL THROUGH */
2980         case XATTRBLOCK:
2981         case XBLOCK:
2982             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2983             PL_expect = XSTATE;
2984             break;
2985         case XATTRTERM:
2986         case XTERMBLOCK:
2987             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2988             PL_expect = XSTATE;
2989             break;
2990         default: {
2991                 char *t;
2992                 if (PL_oldoldbufptr == PL_last_lop)
2993                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2994                 else
2995                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2996                 s = skipspace(s);
2997                 if (*s == '}')
2998                     OPERATOR(HASHBRACK);
2999                 /* This hack serves to disambiguate a pair of curlies
3000                  * as being a block or an anon hash.  Normally, expectation
3001                  * determines that, but in cases where we're not in a
3002                  * position to expect anything in particular (like inside
3003                  * eval"") we have to resolve the ambiguity.  This code
3004                  * covers the case where the first term in the curlies is a
3005                  * quoted string.  Most other cases need to be explicitly
3006                  * disambiguated by prepending a `+' before the opening
3007                  * curly in order to force resolution as an anon hash.
3008                  *
3009                  * XXX should probably propagate the outer expectation
3010                  * into eval"" to rely less on this hack, but that could
3011                  * potentially break current behavior of eval"".
3012                  * GSAR 97-07-21
3013                  */
3014                 t = s;
3015                 if (*s == '\'' || *s == '"' || *s == '`') {
3016                     /* common case: get past first string, handling escapes */
3017                     for (t++; t < PL_bufend && *t != *s;)
3018                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3019                             t++;
3020                     t++;
3021                 }
3022                 else if (*s == 'q') {
3023                     if (++t < PL_bufend
3024                         && (!isALNUM(*t)
3025                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3026                                 && !isALNUM(*t))))
3027                     {
3028                         char *tmps;
3029                         char open, close, term;
3030                         I32 brackets = 1;
3031
3032                         while (t < PL_bufend && isSPACE(*t))
3033                             t++;
3034                         term = *t;
3035                         open = term;
3036                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3037                             term = tmps[5];
3038                         close = term;
3039                         if (open == close)
3040                             for (t++; t < PL_bufend; t++) {
3041                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3042                                     t++;
3043                                 else if (*t == open)
3044                                     break;
3045                             }
3046                         else
3047                             for (t++; t < PL_bufend; t++) {
3048                                 if (*t == '\\' && t+1 < PL_bufend)
3049                                     t++;
3050                                 else if (*t == close && --brackets <= 0)
3051                                     break;
3052                                 else if (*t == open)
3053                                     brackets++;
3054                             }
3055                     }
3056                     t++;
3057                 }
3058                 else if (isALNUM_lazy_if(t,UTF)) {
3059                     t += UTF8SKIP(t);
3060                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3061                          t += UTF8SKIP(t);
3062                 }
3063                 while (t < PL_bufend && isSPACE(*t))
3064                     t++;
3065                 /* if comma follows first term, call it an anon hash */
3066                 /* XXX it could be a comma expression with loop modifiers */
3067                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3068                                    || (*t == '=' && t[1] == '>')))
3069                     OPERATOR(HASHBRACK);
3070                 if (PL_expect == XREF)
3071                     PL_expect = XTERM;
3072                 else {
3073                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3074                     PL_expect = XSTATE;
3075                 }
3076             }
3077             break;
3078         }
3079         yylval.ival = CopLINE(PL_curcop);
3080         if (isSPACE(*s) || *s == '#')
3081             PL_copline = NOLINE;   /* invalidate current command line number */
3082         TOKEN('{');
3083     case '}':
3084       rightbracket:
3085         s++;
3086         if (PL_lex_brackets <= 0)
3087             yyerror("Unmatched right curly bracket");
3088         else
3089             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3090         if (PL_lex_brackets < PL_lex_formbrack)
3091             PL_lex_formbrack = 0;
3092         if (PL_lex_state == LEX_INTERPNORMAL) {
3093             if (PL_lex_brackets == 0) {
3094                 if (PL_expect & XFAKEBRACK) {
3095                     PL_expect &= XENUMMASK;
3096                     PL_lex_state = LEX_INTERPEND;
3097                     PL_bufptr = s;
3098                     return yylex();     /* ignore fake brackets */
3099                 }
3100                 if (*s == '-' && s[1] == '>')
3101                     PL_lex_state = LEX_INTERPENDMAYBE;
3102                 else if (*s != '[' && *s != '{')
3103                     PL_lex_state = LEX_INTERPEND;
3104             }
3105         }
3106         if (PL_expect & XFAKEBRACK) {
3107             PL_expect &= XENUMMASK;
3108             PL_bufptr = s;
3109             return yylex();             /* ignore fake brackets */
3110         }
3111         force_next('}');
3112         TOKEN(';');
3113     case '&':
3114         s++;
3115         tmp = *s++;
3116         if (tmp == '&')
3117             AOPERATOR(ANDAND);
3118         s--;
3119         if (PL_expect == XOPERATOR) {
3120             if (ckWARN(WARN_SEMICOLON)
3121                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3122             {
3123                 CopLINE_dec(PL_curcop);
3124                 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3125                 CopLINE_inc(PL_curcop);
3126             }
3127             BAop(OP_BIT_AND);
3128         }
3129
3130         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3131         if (*PL_tokenbuf) {
3132             PL_expect = XOPERATOR;
3133             force_ident(PL_tokenbuf, '&');
3134         }
3135         else
3136             PREREF('&');
3137         yylval.ival = (OPpENTERSUB_AMPER<<8);
3138         TERM('&');
3139
3140     case '|':
3141         s++;
3142         tmp = *s++;
3143         if (tmp == '|')
3144             AOPERATOR(OROR);
3145         s--;
3146         BOop(OP_BIT_OR);
3147     case '=':
3148         s++;
3149         tmp = *s++;
3150         if (tmp == '=')
3151             Eop(OP_EQ);
3152         if (tmp == '>')
3153             OPERATOR(',');
3154         if (tmp == '~')
3155             PMop(OP_MATCH);
3156         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3157             Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3158         s--;
3159         if (PL_expect == XSTATE && isALPHA(tmp) &&
3160                 (s == PL_linestart+1 || s[-2] == '\n') )
3161         {
3162             if (PL_in_eval && !PL_rsfp) {
3163                 d = PL_bufend;
3164                 while (s < d) {
3165                     if (*s++ == '\n') {
3166                         incline(s);
3167                         if (strnEQ(s,"=cut",4)) {
3168                             s = strchr(s,'\n');
3169                             if (s)
3170                                 s++;
3171                             else
3172                                 s = d;
3173                             incline(s);
3174                             goto retry;
3175                         }
3176                     }
3177                 }
3178                 goto retry;
3179             }
3180             s = PL_bufend;
3181             PL_doextract = TRUE;
3182             goto retry;
3183         }
3184         if (PL_lex_brackets < PL_lex_formbrack) {
3185             char *t;
3186 #ifdef PERL_STRICT_CR
3187             for (t = s; *t == ' ' || *t == '\t'; t++) ;
3188 #else
3189             for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
3190 #endif
3191             if (*t == '\n' || *t == '#') {
3192                 s--;
3193                 PL_expect = XBLOCK;
3194                 goto leftbracket;
3195             }
3196         }
3197         yylval.ival = 0;
3198         OPERATOR(ASSIGNOP);
3199     case '!':
3200         s++;
3201         tmp = *s++;
3202         if (tmp == '=')
3203             Eop(OP_NE);
3204         if (tmp == '~')
3205             PMop(OP_NOT);
3206         s--;
3207         OPERATOR('!');
3208     case '<':
3209         if (PL_expect != XOPERATOR) {
3210             if (s[1] != '<' && !strchr(s,'>'))
3211                 check_uni();
3212             if (s[1] == '<')
3213                 s = scan_heredoc(s);
3214             else
3215                 s = scan_inputsymbol(s);
3216             TERM(sublex_start());
3217         }
3218         s++;
3219         tmp = *s++;
3220         if (tmp == '<')
3221             SHop(OP_LEFT_SHIFT);
3222         if (tmp == '=') {
3223             tmp = *s++;
3224             if (tmp == '>')
3225                 Eop(OP_NCMP);
3226             s--;
3227             Rop(OP_LE);
3228         }
3229         s--;
3230         Rop(OP_LT);
3231     case '>':
3232         s++;
3233         tmp = *s++;
3234         if (tmp == '>')
3235             SHop(OP_RIGHT_SHIFT);
3236         if (tmp == '=')
3237             Rop(OP_GE);
3238         s--;
3239         Rop(OP_GT);
3240
3241     case '$':
3242         CLINE;
3243
3244         if (PL_expect == XOPERATOR) {
3245             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3246                 PL_expect = XTERM;
3247                 depcom();
3248                 return ','; /* grandfather non-comma-format format */
3249             }
3250         }
3251
3252         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3253             PL_tokenbuf[0] = '@';
3254             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3255                            sizeof PL_tokenbuf - 1, FALSE);
3256             if (PL_expect == XOPERATOR)
3257                 no_op("Array length", s);
3258             if (!PL_tokenbuf[1])
3259                 PREREF(DOLSHARP);
3260             PL_expect = XOPERATOR;
3261             PL_pending_ident = '#';
3262             TOKEN(DOLSHARP);
3263         }
3264
3265         PL_tokenbuf[0] = '$';
3266         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3267                        sizeof PL_tokenbuf - 1, FALSE);
3268         if (PL_expect == XOPERATOR)
3269             no_op("Scalar", s);
3270         if (!PL_tokenbuf[1]) {
3271             if (s == PL_bufend)
3272                 yyerror("Final $ should be \\$ or $name");
3273             PREREF('$');
3274         }
3275
3276         /* This kludge not intended to be bulletproof. */
3277         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3278             yylval.opval = newSVOP(OP_CONST, 0,
3279                                    newSViv((IV)PL_compiling.cop_arybase));
3280             yylval.opval->op_private = OPpCONST_ARYBASE;
3281             TERM(THING);
3282         }
3283
3284         d = s;
3285         tmp = (I32)*s;
3286         if (PL_lex_state == LEX_NORMAL)
3287             s = skipspace(s);
3288
3289         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3290             char *t;
3291             if (*s == '[') {
3292                 PL_tokenbuf[0] = '@';
3293                 if (ckWARN(WARN_SYNTAX)) {
3294                     for(t = s + 1;
3295                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3296                         t++) ;
3297                     if (*t++ == ',') {
3298                         PL_bufptr = skipspace(PL_bufptr);
3299                         while (t < PL_bufend && *t != ']')
3300                             t++;
3301                         Perl_warner(aTHX_ WARN_SYNTAX,
3302                                 "Multidimensional syntax %.*s not supported",
3303                                 (t - PL_bufptr) + 1, PL_bufptr);
3304                     }
3305                 }
3306             }
3307             else if (*s == '{') {
3308                 PL_tokenbuf[0] = '%';
3309                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3310                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3311                 {
3312                     char tmpbuf[sizeof PL_tokenbuf];
3313                     STRLEN len;
3314                     for (t++; isSPACE(*t); t++) ;
3315                     if (isIDFIRST_lazy_if(t,UTF)) {
3316                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3317                         for (; isSPACE(*t); t++) ;
3318                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3319                             Perl_warner(aTHX_ WARN_SYNTAX,
3320                                 "You need to quote \"%s\"", tmpbuf);
3321                     }
3322                 }
3323             }
3324         }
3325
3326         PL_expect = XOPERATOR;
3327         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3328             bool islop = (PL_last_lop == PL_oldoldbufptr);
3329             if (!islop || PL_last_lop_op == OP_GREPSTART)
3330                 PL_expect = XOPERATOR;
3331             else if (strchr("$@\"'`q", *s))
3332                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3333             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3334                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3335             else if (isIDFIRST_lazy_if(s,UTF)) {
3336                 char tmpbuf[sizeof PL_tokenbuf];
3337                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3338                 if ((tmp = keyword(tmpbuf, len))) {
3339                     /* binary operators exclude handle interpretations */
3340                     switch (tmp) {
3341                     case -KEY_x:
3342                     case -KEY_eq:
3343                     case -KEY_ne:
3344                     case -KEY_gt:
3345                     case -KEY_lt:
3346                     case -KEY_ge:
3347                     case -KEY_le:
3348                     case -KEY_cmp:
3349                         break;
3350                     default:
3351                         PL_expect = XTERM;      /* e.g. print $fh length() */
3352                         break;
3353                     }
3354                 }
3355                 else {
3356                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3357                     if (gv && GvCVu(gv))
3358                         PL_expect = XTERM;      /* e.g. print $fh subr() */
3359                 }
3360             }
3361             else if (isDIGIT(*s))
3362                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3363             else if (*s == '.' && isDIGIT(s[1]))
3364                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3365             else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3366                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3367             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3368                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3369         }
3370         PL_pending_ident = '$';
3371         TOKEN('$');
3372
3373     case '@':
3374         if (PL_expect == XOPERATOR)
3375             no_op("Array", s);
3376         PL_tokenbuf[0] = '@';
3377         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3378         if (!PL_tokenbuf[1]) {
3379             if (s == PL_bufend)
3380                 yyerror("Final @ should be \\@ or @name");
3381             PREREF('@');
3382         }
3383         if (PL_lex_state == LEX_NORMAL)
3384             s = skipspace(s);
3385         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3386             if (*s == '{')
3387                 PL_tokenbuf[0] = '%';
3388
3389             /* Warn about @ where they meant $. */
3390             if (ckWARN(WARN_SYNTAX)) {
3391                 if (*s == '[' || *s == '{') {
3392                     char *t = s + 1;
3393                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3394                         t++;
3395                     if (*t == '}' || *t == ']') {
3396                         t++;
3397                         PL_bufptr = skipspace(PL_bufptr);
3398                         Perl_warner(aTHX_ WARN_SYNTAX,
3399                             "Scalar value %.*s better written as $%.*s",
3400                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3401                     }
3402                 }
3403             }
3404         }
3405         PL_pending_ident = '@';
3406         TERM('@');
3407
3408     case '/':                   /* may either be division or pattern */
3409     case '?':                   /* may either be conditional or pattern */
3410         if (PL_expect != XOPERATOR) {
3411             /* Disable warning on "study /blah/" */
3412             if (PL_oldoldbufptr == PL_last_uni 
3413                 && (*PL_last_uni != 's' || s - PL_last_uni < 5 
3414                     || memNE(PL_last_uni, "study", 5)
3415                     || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3416                 check_uni();
3417             s = scan_pat(s,OP_MATCH);
3418             TERM(sublex_start());
3419         }
3420         tmp = *s++;
3421         if (tmp == '/')
3422             Mop(OP_DIVIDE);
3423         OPERATOR(tmp);
3424
3425     case '.':
3426         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3427 #ifdef PERL_STRICT_CR
3428             && s[1] == '\n'
3429 #else
3430             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3431 #endif
3432             && (s == PL_linestart || s[-1] == '\n') )
3433         {
3434             PL_lex_formbrack = 0;
3435             PL_expect = XSTATE;
3436             goto rightbracket;
3437         }
3438         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3439             tmp = *s++;
3440             if (*s == tmp) {
3441                 s++;
3442                 if (*s == tmp) {
3443                     s++;
3444                     yylval.ival = OPf_SPECIAL;
3445                 }
3446                 else
3447                     yylval.ival = 0;
3448                 OPERATOR(DOTDOT);
3449             }
3450             if (PL_expect != XOPERATOR)
3451                 check_uni();
3452             Aop(OP_CONCAT);
3453         }
3454         /* FALL THROUGH */
3455     case '0': case '1': case '2': case '3': case '4':
3456     case '5': case '6': case '7': case '8': case '9':
3457         s = scan_num(s);
3458         if (PL_expect == XOPERATOR)
3459             no_op("Number",s);
3460         TERM(THING);
3461
3462     case '\'':
3463         s = scan_str(s,FALSE,FALSE);
3464         if (PL_expect == XOPERATOR) {
3465             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3466                 PL_expect = XTERM;
3467                 depcom();
3468                 return ',';     /* grandfather non-comma-format format */
3469             }
3470             else
3471                 no_op("String",s);
3472         }
3473         if (!s)
3474             missingterm((char*)0);
3475         yylval.ival = OP_CONST;
3476         TERM(sublex_start());
3477
3478     case '"':
3479         s = scan_str(s,FALSE,FALSE);
3480         if (PL_expect == XOPERATOR) {
3481             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3482                 PL_expect = XTERM;
3483                 depcom();
3484                 return ',';     /* grandfather non-comma-format format */
3485             }
3486             else
3487                 no_op("String",s);
3488         }
3489         if (!s)
3490             missingterm((char*)0);
3491         yylval.ival = OP_CONST;
3492         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3493             if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
3494                 yylval.ival = OP_STRINGIFY;
3495                 break;
3496             }
3497         }
3498         TERM(sublex_start());
3499
3500     case '`':
3501         s = scan_str(s,FALSE,FALSE);
3502         if (PL_expect == XOPERATOR)
3503             no_op("Backticks",s);
3504         if (!s)
3505             missingterm((char*)0);
3506         yylval.ival = OP_BACKTICK;
3507         set_csh();
3508         TERM(sublex_start());
3509
3510     case '\\':
3511         s++;
3512         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3513             Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3514                         *s, *s);
3515         if (PL_expect == XOPERATOR)
3516             no_op("Backslash",s);
3517         OPERATOR(REFGEN);
3518
3519     case 'v':
3520         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3521             char *start = s;
3522             start++;
3523             start++;
3524             while (isDIGIT(*start) || *start == '_')
3525                 start++;
3526             if (*start == '.' && isDIGIT(start[1])) {
3527                 s = scan_num(s);
3528                 TERM(THING);
3529             }
3530             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3531             else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) {
3532                 char c = *start;
3533                 GV *gv;
3534                 *start = '\0';
3535                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3536                 *start = c;
3537                 if (!gv) {
3538                     s = scan_num(s);
3539                     TERM(THING);
3540                 }
3541             }
3542         }
3543         goto keylookup;
3544     case 'x':
3545         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3546             s++;
3547             Mop(OP_REPEAT);
3548         }
3549         goto keylookup;
3550
3551     case '_':
3552     case 'a': case 'A':
3553     case 'b': case 'B':
3554     case 'c': case 'C':
3555     case 'd': case 'D':
3556     case 'e': case 'E':
3557     case 'f': case 'F':
3558     case 'g': case 'G':
3559     case 'h': case 'H':
3560     case 'i': case 'I':
3561     case 'j': case 'J':
3562     case 'k': case 'K':
3563     case 'l': case 'L':
3564     case 'm': case 'M':
3565     case 'n': case 'N':
3566     case 'o': case 'O':
3567     case 'p': case 'P':
3568     case 'q': case 'Q':
3569     case 'r': case 'R':
3570     case 's': case 'S':
3571     case 't': case 'T':
3572     case 'u': case 'U':
3573               case 'V':
3574     case 'w': case 'W':
3575               case 'X':
3576     case 'y': case 'Y':
3577     case 'z': case 'Z':
3578
3579       keylookup: {
3580         gv = Nullgv;
3581         gvp = 0;
3582
3583         PL_bufptr = s;
3584         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3585
3586         /* Some keywords can be followed by any delimiter, including ':' */
3587         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3588                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3589                              (PL_tokenbuf[0] == 'q' &&
3590                               strchr("qwxr", PL_tokenbuf[1])))));
3591
3592         /* x::* is just a word, unless x is "CORE" */
3593         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3594             goto just_a_word;
3595
3596         d = s;
3597         while (d < PL_bufend && isSPACE(*d))
3598                 d++;    /* no comments skipped here, or s### is misparsed */
3599
3600         /* Is this a label? */
3601         if (!tmp && PL_expect == XSTATE
3602               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3603             s = d + 1;
3604             yylval.pval = savepv(PL_tokenbuf);
3605             CLINE;
3606             TOKEN(LABEL);
3607         }
3608
3609         /* Check for keywords */
3610         tmp = keyword(PL_tokenbuf, len);
3611
3612         /* Is this a word before a => operator? */
3613         if (strnEQ(d,"=>",2)) {
3614             CLINE;
3615             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3616             yylval.opval->op_private = OPpCONST_BARE;
3617             TERM(WORD);
3618         }
3619
3620         if (tmp < 0) {                  /* second-class keyword? */
3621             GV *ogv = Nullgv;   /* override (winner) */
3622             GV *hgv = Nullgv;   /* hidden (loser) */
3623             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3624                 CV *cv;
3625                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3626                     (cv = GvCVu(gv)))
3627                 {
3628                     if (GvIMPORTED_CV(gv))
3629                         ogv = gv;
3630                     else if (! CvMETHOD(cv))
3631                         hgv = gv;
3632                 }
3633                 if (!ogv &&
3634                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3635                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3636                     GvCVu(gv) && GvIMPORTED_CV(gv))
3637                 {
3638                     ogv = gv;
3639                 }
3640             }
3641             if (ogv) {
3642                 tmp = 0;                /* overridden by import or by GLOBAL */
3643             }
3644             else if (gv && !gvp
3645                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3646                      && GvCVu(gv)
3647                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3648             {
3649                 tmp = 0;                /* any sub overrides "weak" keyword */
3650             }
3651             else {                      /* no override */
3652                 tmp = -tmp;
3653                 gv = Nullgv;
3654                 gvp = 0;
3655                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3656                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3657                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3658                         "Ambiguous call resolved as CORE::%s(), %s",
3659                          GvENAME(hgv), "qualify as such or use &");
3660             }
3661         }
3662
3663       reserved_word:
3664         switch (tmp) {
3665
3666         default:                        /* not a keyword */
3667           just_a_word: {
3668                 SV *sv;
3669                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3670
3671                 /* Get the rest if it looks like a package qualifier */
3672
3673                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3674                     STRLEN morelen;
3675                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3676                                   TRUE, &morelen);
3677                     if (!morelen)
3678                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3679                                 *s == '\'' ? "'" : "::");
3680                     len += morelen;
3681                 }
3682
3683                 if (PL_expect == XOPERATOR) {
3684                     if (PL_bufptr == PL_linestart) {
3685                         CopLINE_dec(PL_curcop);
3686                         Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3687                         CopLINE_inc(PL_curcop);
3688                     }
3689                     else
3690                         no_op("Bareword",s);
3691                 }
3692
3693                 /* Look for a subroutine with this name in current package,
3694                    unless name is "Foo::", in which case Foo is a bearword
3695                    (and a package name). */
3696
3697                 if (len > 2 &&
3698                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3699                 {
3700                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3701                         Perl_warner(aTHX_ WARN_BAREWORD, 
3702                             "Bareword \"%s\" refers to nonexistent package",
3703                              PL_tokenbuf);
3704                     len -= 2;
3705                     PL_tokenbuf[len] = '\0';
3706                     gv = Nullgv;
3707                     gvp = 0;
3708                 }
3709                 else {
3710                     len = 0;
3711                     if (!gv)
3712                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3713                 }
3714
3715                 /* if we saw a global override before, get the right name */
3716
3717                 if (gvp) {
3718                     sv = newSVpvn("CORE::GLOBAL::",14);
3719                     sv_catpv(sv,PL_tokenbuf);
3720                 }
3721                 else
3722                     sv = newSVpv(PL_tokenbuf,0);
3723
3724                 /* Presume this is going to be a bareword of some sort. */
3725
3726                 CLINE;
3727                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3728                 yylval.opval->op_private = OPpCONST_BARE;
3729
3730                 /* And if "Foo::", then that's what it certainly is. */
3731
3732                 if (len)
3733                     goto safe_bareword;
3734
3735                 /* See if it's the indirect object for a list operator. */
3736
3737                 if (PL_oldoldbufptr &&
3738                     PL_oldoldbufptr < PL_bufptr &&
3739                     (PL_oldoldbufptr == PL_last_lop
3740                      || PL_oldoldbufptr == PL_last_uni) &&
3741                     /* NO SKIPSPACE BEFORE HERE! */
3742                     (PL_expect == XREF ||
3743                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3744                 {
3745                     bool immediate_paren = *s == '(';
3746
3747                     /* (Now we can afford to cross potential line boundary.) */
3748                     s = skipspace(s);
3749
3750                     /* Two barewords in a row may indicate method call. */
3751
3752                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3753                         return tmp;
3754
3755                     /* If not a declared subroutine, it's an indirect object. */
3756                     /* (But it's an indir obj regardless for sort.) */
3757
3758                     if ((PL_last_lop_op == OP_SORT ||
3759                          (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3760                         (PL_last_lop_op != OP_MAPSTART &&
3761                          PL_last_lop_op != OP_GREPSTART))
3762                     {
3763                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3764                         goto bareword;
3765                     }
3766                 }
3767
3768                 /* If followed by a paren, it's certainly a subroutine. */
3769
3770                 PL_expect = XOPERATOR;
3771                 s = skipspace(s);
3772                 if (*s == '(') {
3773                     CLINE;
3774                     if (gv && GvCVu(gv)) {
3775                         for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3776                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3777                             s = d + 1;
3778                             goto its_constant;
3779                         }
3780                     }
3781                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3782                     PL_expect = XOPERATOR;
3783                     force_next(WORD);
3784                     yylval.ival = 0;
3785                     TOKEN('&');
3786                 }
3787
3788                 /* If followed by var or block, call it a method (unless sub) */
3789
3790                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3791                     PL_last_lop = PL_oldbufptr;
3792                     PL_last_lop_op = OP_METHOD;
3793                     PREBLOCK(METHOD);
3794                 }
3795
3796                 /* If followed by a bareword, see if it looks like indir obj. */
3797
3798                 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3799                     return tmp;
3800
3801                 /* Not a method, so call it a subroutine (if defined) */
3802
3803                 if (gv && GvCVu(gv)) {
3804                     CV* cv;
3805                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3806                         Perl_warner(aTHX_ WARN_AMBIGUOUS,
3807                                 "Ambiguous use of -%s resolved as -&%s()",
3808                                 PL_tokenbuf, PL_tokenbuf);
3809                     /* Check for a constant sub */
3810                     cv = GvCV(gv);
3811                     if ((sv = cv_const_sv(cv))) {
3812                   its_constant:
3813                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3814                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3815                         yylval.opval->op_private = 0;
3816                         TOKEN(WORD);
3817                     }
3818
3819                     /* Resolve to GV now. */
3820                     op_free(yylval.opval);
3821                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3822                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3823                     PL_last_lop = PL_oldbufptr;
3824                     PL_last_lop_op = OP_ENTERSUB;
3825                     /* Is there a prototype? */
3826                     if (SvPOK(cv)) {
3827                         STRLEN len;
3828                         char *proto = SvPV((SV*)cv, len);
3829                         if (!len)
3830                             TERM(FUNC0SUB);
3831                         if (strEQ(proto, "$"))
3832                             OPERATOR(UNIOPSUB);
3833                         if (*proto == '&' && *s == '{') {
3834                             sv_setpv(PL_subname,"__ANON__");
3835                             PREBLOCK(LSTOPSUB);
3836                         }
3837                     }
3838                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3839                     PL_expect = XTERM;
3840                     force_next(WORD);
3841                     TOKEN(NOAMP);
3842                 }
3843
3844                 /* Call it a bare word */
3845
3846                 if (PL_hints & HINT_STRICT_SUBS)
3847                     yylval.opval->op_private |= OPpCONST_STRICT;
3848                 else {
3849                 bareword:
3850                     if (ckWARN(WARN_RESERVED)) {
3851                         if (lastchar != '-') {
3852                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3853                             if (!*d)
3854                                 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3855                                        PL_tokenbuf);
3856                         }
3857                     }
3858                 }
3859
3860             safe_bareword:
3861                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
3862                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3863                         "Operator or semicolon missing before %c%s",
3864                         lastchar, PL_tokenbuf);
3865                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3866                         "Ambiguous use of %c resolved as operator %c",
3867                         lastchar, lastchar);
3868                 }
3869                 TOKEN(WORD);
3870             }
3871
3872         case KEY___FILE__:
3873             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3874                                         newSVpv(CopFILE(PL_curcop),0));
3875             TERM(THING);
3876
3877         case KEY___LINE__:
3878             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3879                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
3880             TERM(THING);
3881
3882         case KEY___PACKAGE__:
3883             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3884                                         (PL_curstash
3885                                          ? newSVsv(PL_curstname)
3886                                          : &PL_sv_undef));
3887             TERM(THING);
3888
3889         case KEY___DATA__:
3890         case KEY___END__: {
3891             GV *gv;
3892
3893             /*SUPPRESS 560*/
3894             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3895                 char *pname = "main";
3896                 if (PL_tokenbuf[2] == 'D')
3897                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3898                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3899                 GvMULTI_on(gv);
3900                 if (!GvIO(gv))
3901                     GvIOp(gv) = newIO();
3902                 IoIFP(GvIOp(gv)) = PL_rsfp;
3903 #if defined(HAS_FCNTL) && defined(F_SETFD)
3904                 {
3905                     int fd = PerlIO_fileno(PL_rsfp);
3906                     fcntl(fd,F_SETFD,fd >= 3);
3907                 }
3908 #endif
3909                 /* Mark this internal pseudo-handle as clean */
3910                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3911                 if (PL_preprocess)
3912                     IoTYPE(GvIOp(gv)) = '|';
3913                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3914                     IoTYPE(GvIOp(gv)) = '-';
3915                 else
3916                     IoTYPE(GvIOp(gv)) = '<';
3917 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
3918                 /* if the script was opened in binmode, we need to revert
3919                  * it to text mode for compatibility; but only iff it has CRs
3920                  * XXX this is a questionable hack at best. */
3921                 if (PL_bufend-PL_bufptr > 2
3922                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
3923                 {
3924                     Off_t loc = 0;
3925                     if (IoTYPE(GvIOp(gv)) == '<') {
3926                         loc = PerlIO_tell(PL_rsfp);
3927                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
3928                     }
3929                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
3930 #if defined(__BORLANDC__)
3931                         /* XXX see note in do_binmode() */
3932                         ((FILE*)PL_rsfp)->flags |= _F_BIN;
3933 #endif
3934                         if (loc > 0)
3935                             PerlIO_seek(PL_rsfp, loc, 0);
3936                     }
3937                 }
3938 #endif
3939                 PL_rsfp = Nullfp;
3940             }
3941             goto fake_eof;
3942         }
3943
3944         case KEY_AUTOLOAD:
3945         case KEY_DESTROY:
3946         case KEY_BEGIN:
3947         case KEY_CHECK:
3948         case KEY_INIT:
3949         case KEY_END:
3950             if (PL_expect == XSTATE) {
3951                 s = PL_bufptr;
3952                 goto really_sub;
3953             }
3954             goto just_a_word;
3955
3956         case KEY_CORE:
3957             if (*s == ':' && s[1] == ':') {
3958                 s += 2;
3959                 d = s;
3960                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3961                 tmp = keyword(PL_tokenbuf, len);
3962                 if (tmp < 0)
3963                     tmp = -tmp;
3964                 goto reserved_word;
3965             }
3966             goto just_a_word;
3967
3968         case KEY_abs:
3969             UNI(OP_ABS);
3970
3971         case KEY_alarm:
3972             UNI(OP_ALARM);
3973
3974         case KEY_accept:
3975             LOP(OP_ACCEPT,XTERM);
3976
3977         case KEY_and:
3978             OPERATOR(ANDOP);
3979
3980         case KEY_atan2:
3981             LOP(OP_ATAN2,XTERM);
3982
3983         case KEY_bind:
3984             LOP(OP_BIND,XTERM);
3985
3986         case KEY_binmode:
3987             LOP(OP_BINMODE,XTERM);
3988
3989         case KEY_bless:
3990             LOP(OP_BLESS,XTERM);
3991
3992         case KEY_chop:
3993             UNI(OP_CHOP);
3994
3995         case KEY_continue:
3996             PREBLOCK(CONTINUE);
3997
3998         case KEY_chdir:
3999             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
4000             UNI(OP_CHDIR);
4001
4002         case KEY_close:
4003             UNI(OP_CLOSE);
4004
4005         case KEY_closedir:
4006             UNI(OP_CLOSEDIR);
4007
4008         case KEY_cmp:
4009             Eop(OP_SCMP);
4010
4011         case KEY_caller:
4012             UNI(OP_CALLER);
4013
4014         case KEY_crypt:
4015 #ifdef FCRYPT
4016             if (!PL_cryptseen) {
4017                 PL_cryptseen = TRUE;
4018                 init_des();
4019             }
4020 #endif
4021             LOP(OP_CRYPT,XTERM);
4022
4023         case KEY_chmod:
4024             if (ckWARN(WARN_CHMOD)) {
4025                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4026                 if (*d != '0' && isDIGIT(*d))
4027                     Perl_warner(aTHX_ WARN_CHMOD,
4028                                 "chmod() mode argument is missing initial 0");
4029             }
4030             LOP(OP_CHMOD,XTERM);
4031
4032         case KEY_chown:
4033             LOP(OP_CHOWN,XTERM);
4034
4035         case KEY_connect:
4036             LOP(OP_CONNECT,XTERM);
4037
4038         case KEY_chr:
4039             UNI(OP_CHR);
4040
4041         case KEY_cos:
4042             UNI(OP_COS);
4043
4044         case KEY_chroot:
4045             UNI(OP_CHROOT);
4046
4047         case KEY_do:
4048             s = skipspace(s);
4049             if (*s == '{')
4050                 PRETERMBLOCK(DO);
4051             if (*s != '\'')
4052                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4053             OPERATOR(DO);
4054
4055         case KEY_die:
4056             PL_hints |= HINT_BLOCK_SCOPE;
4057             LOP(OP_DIE,XTERM);
4058
4059         case KEY_defined:
4060             UNI(OP_DEFINED);
4061
4062         case KEY_delete:
4063             UNI(OP_DELETE);
4064
4065         case KEY_dbmopen:
4066             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4067             LOP(OP_DBMOPEN,XTERM);
4068
4069         case KEY_dbmclose:
4070             UNI(OP_DBMCLOSE);
4071
4072         case KEY_dump:
4073             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4074             LOOPX(OP_DUMP);
4075
4076         case KEY_else:
4077             PREBLOCK(ELSE);
4078
4079         case KEY_elsif:
4080             yylval.ival = CopLINE(PL_curcop);
4081             OPERATOR(ELSIF);
4082
4083         case KEY_eq:
4084             Eop(OP_SEQ);
4085
4086         case KEY_exists:
4087             UNI(OP_EXISTS);
4088             
4089         case KEY_exit:
4090             UNI(OP_EXIT);
4091
4092         case KEY_eval:
4093             s = skipspace(s);
4094             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4095             UNIBRACK(OP_ENTEREVAL);
4096
4097         case KEY_eof:
4098             UNI(OP_EOF);
4099
4100         case KEY_exp:
4101             UNI(OP_EXP);
4102
4103         case KEY_each:
4104             UNI(OP_EACH);
4105
4106         case KEY_exec:
4107             set_csh();
4108             LOP(OP_EXEC,XREF);
4109
4110         case KEY_endhostent:
4111             FUN0(OP_EHOSTENT);
4112
4113         case KEY_endnetent:
4114             FUN0(OP_ENETENT);
4115
4116         case KEY_endservent:
4117             FUN0(OP_ESERVENT);
4118
4119         case KEY_endprotoent:
4120             FUN0(OP_EPROTOENT);
4121
4122         case KEY_endpwent:
4123             FUN0(OP_EPWENT);
4124
4125         case KEY_endgrent:
4126             FUN0(OP_EGRENT);
4127
4128         case KEY_for:
4129         case KEY_foreach:
4130             yylval.ival = CopLINE(PL_curcop);
4131             s = skipspace(s);
4132             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4133                 char *p = s;
4134                 if ((PL_bufend - p) >= 3 &&
4135                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4136                     p += 2;
4137                 else if ((PL_bufend - p) >= 4 &&
4138                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4139                     p += 3;
4140                 p = skipspace(p);
4141                 if (isIDFIRST_lazy_if(p,UTF)) {
4142                     p = scan_ident(p, PL_bufend,
4143                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4144                     p = skipspace(p);
4145                 }
4146                 if (*p != '$')
4147                     Perl_croak(aTHX_ "Missing $ on loop variable");
4148             }
4149             OPERATOR(FOR);
4150
4151         case KEY_formline:
4152             LOP(OP_FORMLINE,XTERM);
4153
4154         case KEY_fork:
4155             FUN0(OP_FORK);
4156
4157         case KEY_fcntl:
4158             LOP(OP_FCNTL,XTERM);
4159
4160         case KEY_fileno:
4161             UNI(OP_FILENO);
4162
4163         case KEY_flock:
4164             LOP(OP_FLOCK,XTERM);
4165
4166         case KEY_gt:
4167             Rop(OP_SGT);
4168
4169         case KEY_ge:
4170             Rop(OP_SGE);
4171
4172         case KEY_grep:
4173             LOP(OP_GREPSTART, XREF);
4174
4175         case KEY_goto:
4176             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4177             LOOPX(OP_GOTO);
4178
4179         case KEY_gmtime:
4180             UNI(OP_GMTIME);
4181
4182         case KEY_getc:
4183             UNI(OP_GETC);
4184
4185         case KEY_getppid:
4186             FUN0(OP_GETPPID);
4187
4188         case KEY_getpgrp:
4189             UNI(OP_GETPGRP);
4190
4191         case KEY_getpriority:
4192             LOP(OP_GETPRIORITY,XTERM);
4193
4194         case KEY_getprotobyname:
4195             UNI(OP_GPBYNAME);
4196
4197         case KEY_getprotobynumber:
4198             LOP(OP_GPBYNUMBER,XTERM);
4199
4200         case KEY_getprotoent:
4201             FUN0(OP_GPROTOENT);
4202
4203         case KEY_getpwent:
4204             FUN0(OP_GPWENT);
4205
4206         case KEY_getpwnam:
4207             UNI(OP_GPWNAM);
4208
4209         case KEY_getpwuid:
4210             UNI(OP_GPWUID);
4211
4212         case KEY_getpeername:
4213             UNI(OP_GETPEERNAME);
4214
4215         case KEY_gethostbyname:
4216             UNI(OP_GHBYNAME);
4217
4218         case KEY_gethostbyaddr:
4219             LOP(OP_GHBYADDR,XTERM);
4220
4221         case KEY_gethostent:
4222             FUN0(OP_GHOSTENT);
4223
4224         case KEY_getnetbyname:
4225             UNI(OP_GNBYNAME);
4226
4227         case KEY_getnetbyaddr:
4228             LOP(OP_GNBYADDR,XTERM);
4229
4230         case KEY_getnetent:
4231             FUN0(OP_GNETENT);
4232
4233         case KEY_getservbyname:
4234             LOP(OP_GSBYNAME,XTERM);
4235
4236         case KEY_getservbyport:
4237             LOP(OP_GSBYPORT,XTERM);
4238
4239         case KEY_getservent:
4240             FUN0(OP_GSERVENT);
4241
4242         case KEY_getsockname:
4243             UNI(OP_GETSOCKNAME);
4244
4245         case KEY_getsockopt:
4246             LOP(OP_GSOCKOPT,XTERM);
4247
4248         case KEY_getgrent:
4249             FUN0(OP_GGRENT);
4250
4251         case KEY_getgrnam:
4252             UNI(OP_GGRNAM);
4253
4254         case KEY_getgrgid:
4255             UNI(OP_GGRGID);
4256
4257         case KEY_getlogin:
4258             FUN0(OP_GETLOGIN);
4259
4260         case KEY_glob:
4261             set_csh();
4262             LOP(OP_GLOB,XTERM);
4263
4264         case KEY_hex:
4265             UNI(OP_HEX);
4266
4267         case KEY_if:
4268             yylval.ival = CopLINE(PL_curcop);
4269             OPERATOR(IF);
4270
4271         case KEY_index:
4272             LOP(OP_INDEX,XTERM);
4273
4274         case KEY_int:
4275             UNI(OP_INT);
4276
4277         case KEY_ioctl:
4278             LOP(OP_IOCTL,XTERM);
4279
4280         case KEY_join:
4281             LOP(OP_JOIN,XTERM);
4282
4283         case KEY_keys:
4284             UNI(OP_KEYS);
4285
4286         case KEY_kill:
4287             LOP(OP_KILL,XTERM);
4288
4289         case KEY_last:
4290             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4291             LOOPX(OP_LAST);
4292             
4293         case KEY_lc:
4294             UNI(OP_LC);
4295
4296         case KEY_lcfirst:
4297             UNI(OP_LCFIRST);
4298
4299         case KEY_local:
4300             yylval.ival = 0;
4301             OPERATOR(LOCAL);
4302
4303         case KEY_length:
4304             UNI(OP_LENGTH);
4305
4306         case KEY_lt:
4307             Rop(OP_SLT);
4308
4309         case KEY_le:
4310             Rop(OP_SLE);
4311
4312         case KEY_localtime:
4313             UNI(OP_LOCALTIME);
4314
4315         case KEY_log:
4316             UNI(OP_LOG);
4317
4318         case KEY_link:
4319             LOP(OP_LINK,XTERM);
4320
4321         case KEY_listen:
4322             LOP(OP_LISTEN,XTERM);
4323
4324         case KEY_lock:
4325             UNI(OP_LOCK);
4326
4327         case KEY_lstat:
4328             UNI(OP_LSTAT);
4329
4330         case KEY_m:
4331             s = scan_pat(s,OP_MATCH);
4332             TERM(sublex_start());
4333
4334         case KEY_map:
4335             LOP(OP_MAPSTART, XREF);
4336
4337         case KEY_mkdir:
4338             LOP(OP_MKDIR,XTERM);
4339
4340         case KEY_msgctl:
4341             LOP(OP_MSGCTL,XTERM);
4342
4343         case KEY_msgget:
4344             LOP(OP_MSGGET,XTERM);
4345
4346         case KEY_msgrcv:
4347             LOP(OP_MSGRCV,XTERM);
4348
4349         case KEY_msgsnd:
4350             LOP(OP_MSGSND,XTERM);
4351
4352         case KEY_our:
4353         case KEY_my:
4354             PL_in_my = tmp;
4355             s = skipspace(s);
4356             if (isIDFIRST_lazy_if(s,UTF)) {
4357                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4358                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4359                     goto really_sub;
4360                 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
4361                 if (!PL_in_my_stash) {
4362                     char tmpbuf[1024];
4363                     PL_bufptr = s;
4364                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4365                     yyerror(tmpbuf);
4366                 }
4367             }
4368             yylval.ival = 1;
4369             OPERATOR(MY);
4370
4371         case KEY_next:
4372             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4373             LOOPX(OP_NEXT);
4374
4375         case KEY_ne:
4376             Eop(OP_SNE);
4377
4378         case KEY_no:
4379             if (PL_expect != XSTATE)
4380                 yyerror("\"no\" not allowed in expression");
4381             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4382             s = force_version(s);
4383             yylval.ival = 0;
4384             OPERATOR(USE);
4385
4386         case KEY_not:
4387             if (*s == '(' || (s = skipspace(s), *s == '('))
4388                 FUN1(OP_NOT);
4389             else
4390                 OPERATOR(NOTOP);
4391
4392         case KEY_open:
4393             s = skipspace(s);
4394             if (isIDFIRST_lazy_if(s,UTF)) {
4395                 char *t;
4396                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4397                 t = skipspace(d);
4398                 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4399                     Perl_warner(aTHX_ WARN_PRECEDENCE,
4400                            "Precedence problem: open %.*s should be open(%.*s)",
4401                             d-s,s, d-s,s);
4402             }
4403             LOP(OP_OPEN,XTERM);
4404
4405         case KEY_or:
4406             yylval.ival = OP_OR;
4407             OPERATOR(OROP);
4408