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