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