Include variable names in "Use of uninitialized value" warnings
[p5sagit/p5-mst-13.2.git] / toke.c
1 /*    toke.c
2  *
3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
4  *    2000, 2001, 2002, 2003, 2004, by Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  *   "It all comes from here, the stench and the peril."  --Frodo
13  */
14
15 /*
16  * This file is the lexer for Perl.  It's closely linked to the
17  * parser, perly.y.
18  *
19  * The main routine is yylex(), which returns the next token.
20  */
21
22 #include "EXTERN.h"
23 #define PERL_IN_TOKE_C
24 #include "perl.h"
25
26 #define yychar  (*PL_yycharp)
27 #define yylval  (*PL_yylvalp)
28
29 static char ident_too_long[] = "Identifier too long";
30 static char c_without_g[] = "Use of /c modifier is meaningless without /g";
31 static char c_in_subst[] = "Use of /c modifier is meaningless in s///";
32
33 static void restore_rsfp(pTHX_ void *f);
34 #ifndef PERL_NO_UTF16_FILTER
35 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
36 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
37 #endif
38
39 #define XFAKEBRACK 128
40 #define XENUMMASK 127
41
42 #ifdef USE_UTF8_SCRIPTS
43 #   define UTF (!IN_BYTES)
44 #else
45 #   define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
46 #endif
47
48 /* In variables named $^X, these are the legal values for X.
49  * 1999-02-27 mjd-perl-patch@plover.com */
50 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
51
52 /* On MacOS, respect nonbreaking spaces */
53 #ifdef MACOS_TRADITIONAL
54 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
55 #else
56 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
57 #endif
58
59 /* LEX_* are values for PL_lex_state, the state of the lexer.
60  * They are arranged oddly so that the guard on the switch statement
61  * can get by with a single comparison (if the compiler is smart enough).
62  */
63
64 /* #define LEX_NOTPARSING               11 is done in perl.h. */
65
66 #define LEX_NORMAL              10
67 #define LEX_INTERPNORMAL         9
68 #define LEX_INTERPCASEMOD        8
69 #define LEX_INTERPPUSH           7
70 #define LEX_INTERPSTART          6
71 #define LEX_INTERPEND            5
72 #define LEX_INTERPENDMAYBE       4
73 #define LEX_INTERPCONCAT         3
74 #define LEX_INTERPCONST          2
75 #define LEX_FORMLINE             1
76 #define LEX_KNOWNEXT             0
77
78 #ifdef ff_next
79 #undef ff_next
80 #endif
81
82 #include "keywords.h"
83
84 /* CLINE is a macro that ensures PL_copline has a sane value */
85
86 #ifdef CLINE
87 #undef CLINE
88 #endif
89 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
90
91 /*
92  * Convenience functions to return different tokens and prime the
93  * lexer for the next token.  They all take an argument.
94  *
95  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
96  * OPERATOR     : generic operator
97  * AOPERATOR    : assignment operator
98  * PREBLOCK     : beginning the block after an if, while, foreach, ...
99  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
100  * PREREF       : *EXPR where EXPR is not a simple identifier
101  * TERM         : expression term
102  * LOOPX        : loop exiting command (goto, last, dump, etc)
103  * FTST         : file test operator
104  * FUN0         : zero-argument function
105  * FUN1         : not used, except for not, which isn't a UNIOP
106  * BOop         : bitwise or or xor
107  * BAop         : bitwise and
108  * SHop         : shift operator
109  * PWop         : power operator
110  * PMop         : pattern-matching operator
111  * Aop          : addition-level operator
112  * Mop          : multiplication-level operator
113  * Eop          : equality-testing operator
114  * Rop          : relational operator <= != gt
115  *
116  * Also see LOP and lop() below.
117  */
118
119 /* Note that REPORT() and REPORT2() will be expressions that supply
120  * their own trailing comma, not suitable for statements as such. */
121 #ifdef DEBUGGING /* Serve -DT. */
122 #   define REPORT(x,retval) tokereport(x,s,(int)retval),
123 #   define REPORT2(x,retval) tokereport(x,s, yylval.ival),
124 #else
125 #   define REPORT(x,retval)
126 #   define REPORT2(x,retval)
127 #endif
128
129 #define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
130 #define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
131 #define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
132 #define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
133 #define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
134 #define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
135 #define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
136 #define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
137 #define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERMORDORDOR,PL_bufptr = s,(int)UNIOP)
138 #define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
139 #define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
140 #define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
141 #define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
142 #define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
143 #define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
144 #define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
145 #define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
146 #define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
147 #define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
148 #define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
149
150 /* This bit of chicanery makes a unary function followed by
151  * a parenthesis into a function with one argument, highest precedence.
152  * The UNIDOR macro is for unary functions that can be followed by the //
153  * operator (such as C<shift // 0>).
154  */
155 #define UNI2(f,x) return(yylval.ival = f, \
156         REPORT("uni",f) \
157         PL_expect = x, \
158         PL_bufptr = s, \
159         PL_last_uni = PL_oldbufptr, \
160         PL_last_lop_op = f, \
161         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
162 #define UNI(f)    UNI2(f,XTERM)
163 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
164
165 #define UNIBRACK(f) return(yylval.ival = f, \
166         REPORT("uni",f) \
167         PL_bufptr = s, \
168         PL_last_uni = PL_oldbufptr, \
169         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
170
171 /* grandfather return to old style */
172 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
173
174 #ifdef DEBUGGING
175
176 STATIC void
177 S_tokereport(pTHX_ char *thing, char* s, I32 rv)
178 {
179     DEBUG_T({
180         SV* report = newSVpv(thing, 0);
181         Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
182                 (IV)rv);
183
184         if (s - PL_bufptr > 0)
185             sv_catpvn(report, PL_bufptr, s - PL_bufptr);
186         else {
187             if (PL_oldbufptr && *PL_oldbufptr)
188                 sv_catpv(report, PL_tokenbuf);
189         }
190         PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
191     });
192 }
193
194 #endif
195
196 /*
197  * S_ao
198  *
199  * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
200  * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
201  */
202
203 STATIC int
204 S_ao(pTHX_ int toketype)
205 {
206     if (*PL_bufptr == '=') {
207         PL_bufptr++;
208         if (toketype == ANDAND)
209             yylval.ival = OP_ANDASSIGN;
210         else if (toketype == OROR)
211             yylval.ival = OP_ORASSIGN;
212         else if (toketype == DORDOR)
213             yylval.ival = OP_DORASSIGN;
214         toketype = ASSIGNOP;
215     }
216     return toketype;
217 }
218
219 /*
220  * S_no_op
221  * When Perl expects an operator and finds something else, no_op
222  * prints the warning.  It always prints "<something> found where
223  * operator expected.  It prints "Missing semicolon on previous line?"
224  * if the surprise occurs at the start of the line.  "do you need to
225  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
226  * where the compiler doesn't know if foo is a method call or a function.
227  * It prints "Missing operator before end of line" if there's nothing
228  * after the missing operator, or "... before <...>" if there is something
229  * after the missing operator.
230  */
231
232 STATIC void
233 S_no_op(pTHX_ char *what, char *s)
234 {
235     char *oldbp = PL_bufptr;
236     bool is_first = (PL_oldbufptr == PL_linestart);
237
238     if (!s)
239         s = oldbp;
240     else
241         PL_bufptr = s;
242     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
243     if (ckWARN_d(WARN_SYNTAX)) {
244         if (is_first)
245             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
246                     "\t(Missing semicolon on previous line?)\n");
247         else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
248             char *t;
249             for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
250             if (t < PL_bufptr && isSPACE(*t))
251                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
252                         "\t(Do you need to predeclare %.*s?)\n",
253                     t - PL_oldoldbufptr, PL_oldoldbufptr);
254         }
255         else {
256             assert(s >= oldbp);
257             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
258                     "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
259         }
260     }
261     PL_bufptr = oldbp;
262 }
263
264 /*
265  * S_missingterm
266  * Complain about missing quote/regexp/heredoc terminator.
267  * If it's called with (char *)NULL then it cauterizes the line buffer.
268  * If we're in a delimited string and the delimiter is a control
269  * character, it's reformatted into a two-char sequence like ^C.
270  * This is fatal.
271  */
272
273 STATIC void
274 S_missingterm(pTHX_ char *s)
275 {
276     char tmpbuf[3];
277     char q;
278     if (s) {
279         char *nl = strrchr(s,'\n');
280         if (nl)
281             *nl = '\0';
282     }
283     else if (
284 #ifdef EBCDIC
285         iscntrl(PL_multi_close)
286 #else
287         PL_multi_close < 32 || PL_multi_close == 127
288 #endif
289         ) {
290         *tmpbuf = '^';
291         tmpbuf[1] = toCTRL(PL_multi_close);
292         s = "\\n";
293         tmpbuf[2] = '\0';
294         s = tmpbuf;
295     }
296     else {
297         *tmpbuf = (char)PL_multi_close;
298         tmpbuf[1] = '\0';
299         s = tmpbuf;
300     }
301     q = strchr(s,'"') ? '\'' : '"';
302     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
303 }
304
305 /*
306  * Perl_deprecate
307  */
308
309 void
310 Perl_deprecate(pTHX_ char *s)
311 {
312     if (ckWARN(WARN_DEPRECATED))
313         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
314 }
315
316 void
317 Perl_deprecate_old(pTHX_ char *s)
318 {
319     /* This function should NOT be called for any new deprecated warnings */
320     /* Use Perl_deprecate instead                                         */
321     /*                                                                    */
322     /* It is here to maintain backward compatibility with the pre-5.8     */
323     /* warnings category hierarchy. The "deprecated" category used to     */
324     /* live under the "syntax" category. It is now a top-level category   */
325     /* in its own right.                                                  */
326
327     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
328         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), 
329                         "Use of %s is deprecated", s);
330 }
331
332 /*
333  * depcom
334  * Deprecate a comma-less variable list.
335  */
336
337 STATIC void
338 S_depcom(pTHX)
339 {
340     deprecate_old("comma-less variable list");
341 }
342
343 /*
344  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
345  * utf16-to-utf8-reversed.
346  */
347
348 #ifdef PERL_CR_FILTER
349 static void
350 strip_return(SV *sv)
351 {
352     register char *s = SvPVX(sv);
353     register char *e = s + SvCUR(sv);
354     /* outer loop optimized to do nothing if there are no CR-LFs */
355     while (s < e) {
356         if (*s++ == '\r' && *s == '\n') {
357             /* hit a CR-LF, need to copy the rest */
358             register char *d = s - 1;
359             *d++ = *s++;
360             while (s < e) {
361                 if (*s == '\r' && s[1] == '\n')
362                     s++;
363                 *d++ = *s++;
364             }
365             SvCUR(sv) -= s - d;
366             return;
367         }
368     }
369 }
370
371 STATIC I32
372 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
373 {
374     I32 count = FILTER_READ(idx+1, sv, maxlen);
375     if (count > 0 && !maxlen)
376         strip_return(sv);
377     return count;
378 }
379 #endif
380
381 /*
382  * Perl_lex_start
383  * Initialize variables.  Uses the Perl save_stack to save its state (for
384  * recursive calls to the parser).
385  */
386
387 void
388 Perl_lex_start(pTHX_ SV *line)
389 {
390     char *s;
391     STRLEN len;
392
393     SAVEI32(PL_lex_dojoin);
394     SAVEI32(PL_lex_brackets);
395     SAVEI32(PL_lex_casemods);
396     SAVEI32(PL_lex_starts);
397     SAVEI32(PL_lex_state);
398     SAVEVPTR(PL_lex_inpat);
399     SAVEI32(PL_lex_inwhat);
400     if (PL_lex_state == LEX_KNOWNEXT) {
401         I32 toke = PL_nexttoke;
402         while (--toke >= 0) {
403             SAVEI32(PL_nexttype[toke]);
404             SAVEVPTR(PL_nextval[toke]);
405         }
406         SAVEI32(PL_nexttoke);
407     }
408     SAVECOPLINE(PL_curcop);
409     SAVEPPTR(PL_bufptr);
410     SAVEPPTR(PL_bufend);
411     SAVEPPTR(PL_oldbufptr);
412     SAVEPPTR(PL_oldoldbufptr);
413     SAVEPPTR(PL_last_lop);
414     SAVEPPTR(PL_last_uni);
415     SAVEPPTR(PL_linestart);
416     SAVESPTR(PL_linestr);
417     SAVEGENERICPV(PL_lex_brackstack);
418     SAVEGENERICPV(PL_lex_casestack);
419     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
420     SAVESPTR(PL_lex_stuff);
421     SAVEI32(PL_lex_defer);
422     SAVEI32(PL_sublex_info.sub_inwhat);
423     SAVESPTR(PL_lex_repl);
424     SAVEINT(PL_expect);
425     SAVEINT(PL_lex_expect);
426
427     PL_lex_state = LEX_NORMAL;
428     PL_lex_defer = 0;
429     PL_expect = XSTATE;
430     PL_lex_brackets = 0;
431     New(899, PL_lex_brackstack, 120, char);
432     New(899, PL_lex_casestack, 12, char);
433     PL_lex_casemods = 0;
434     *PL_lex_casestack = '\0';
435     PL_lex_dojoin = 0;
436     PL_lex_starts = 0;
437     PL_lex_stuff = Nullsv;
438     PL_lex_repl = Nullsv;
439     PL_lex_inpat = 0;
440     PL_nexttoke = 0;
441     PL_lex_inwhat = 0;
442     PL_sublex_info.sub_inwhat = 0;
443     PL_linestr = line;
444     if (SvREADONLY(PL_linestr))
445         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
446     s = SvPV(PL_linestr, len);
447     if (!len || s[len-1] != ';') {
448         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
449             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
450         sv_catpvn(PL_linestr, "\n;", 2);
451     }
452     SvTEMP_off(PL_linestr);
453     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
454     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
455     PL_last_lop = PL_last_uni = Nullch;
456     PL_rsfp = 0;
457 }
458
459 /*
460  * Perl_lex_end
461  * Finalizer for lexing operations.  Must be called when the parser is
462  * done with the lexer.
463  */
464
465 void
466 Perl_lex_end(pTHX)
467 {
468     PL_doextract = FALSE;
469 }
470
471 /*
472  * S_incline
473  * This subroutine has nothing to do with tilting, whether at windmills
474  * or pinball tables.  Its name is short for "increment line".  It
475  * increments the current line number in CopLINE(PL_curcop) and checks
476  * to see whether the line starts with a comment of the form
477  *    # line 500 "foo.pm"
478  * If so, it sets the current line number and file to the values in the comment.
479  */
480
481 STATIC void
482 S_incline(pTHX_ char *s)
483 {
484     char *t;
485     char *n;
486     char *e;
487     char ch;
488
489     CopLINE_inc(PL_curcop);
490     if (*s++ != '#')
491         return;
492     while (SPACE_OR_TAB(*s)) s++;
493     if (strnEQ(s, "line", 4))
494         s += 4;
495     else
496         return;
497     if (SPACE_OR_TAB(*s))
498         s++;
499     else
500         return;
501     while (SPACE_OR_TAB(*s)) s++;
502     if (!isDIGIT(*s))
503         return;
504     n = s;
505     while (isDIGIT(*s))
506         s++;
507     while (SPACE_OR_TAB(*s))
508         s++;
509     if (*s == '"' && (t = strchr(s+1, '"'))) {
510         s++;
511         e = t + 1;
512     }
513     else {
514         for (t = s; !isSPACE(*t); t++) ;
515         e = t;
516     }
517     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
518         e++;
519     if (*e != '\n' && *e != '\0')
520         return;         /* false alarm */
521
522     ch = *t;
523     *t = '\0';
524     if (t - s > 0) {
525         CopFILE_free(PL_curcop);
526         CopFILE_set(PL_curcop, s);
527     }
528     *t = ch;
529     CopLINE_set(PL_curcop, atoi(n)-1);
530 }
531
532 /*
533  * S_skipspace
534  * Called to gobble the appropriate amount and type of whitespace.
535  * Skips comments as well.
536  */
537
538 STATIC char *
539 S_skipspace(pTHX_ register char *s)
540 {
541     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
542         while (s < PL_bufend && SPACE_OR_TAB(*s))
543             s++;
544         return s;
545     }
546     for (;;) {
547         STRLEN prevlen;
548         SSize_t oldprevlen, oldoldprevlen;
549         SSize_t oldloplen = 0, oldunilen = 0;
550         while (s < PL_bufend && isSPACE(*s)) {
551             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
552                 incline(s);
553         }
554
555         /* comment */
556         if (s < PL_bufend && *s == '#') {
557             while (s < PL_bufend && *s != '\n')
558                 s++;
559             if (s < PL_bufend) {
560                 s++;
561                 if (PL_in_eval && !PL_rsfp) {
562                     incline(s);
563                     continue;
564                 }
565             }
566         }
567
568         /* only continue to recharge the buffer if we're at the end
569          * of the buffer, we're not reading from a source filter, and
570          * we're in normal lexing mode
571          */
572         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
573                 PL_lex_state == LEX_FORMLINE)
574             return s;
575
576         /* try to recharge the buffer */
577         if ((s = filter_gets(PL_linestr, PL_rsfp,
578                              (prevlen = SvCUR(PL_linestr)))) == Nullch)
579         {
580             /* end of file.  Add on the -p or -n magic */
581             if (PL_minus_n || PL_minus_p) {
582                 sv_setpv(PL_linestr,PL_minus_p ?
583                          ";}continue{print or die qq(-p destination: $!\\n)" :
584                          "");
585                 sv_catpv(PL_linestr,";}");
586                 PL_minus_n = PL_minus_p = 0;
587             }
588             else
589                 sv_setpv(PL_linestr,";");
590
591             /* reset variables for next time we lex */
592             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
593                 = SvPVX(PL_linestr);
594             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
595             PL_last_lop = PL_last_uni = Nullch;
596
597             /* Close the filehandle.  Could be from -P preprocessor,
598              * STDIN, or a regular file.  If we were reading code from
599              * STDIN (because the commandline held no -e or filename)
600              * then we don't close it, we reset it so the code can
601              * read from STDIN too.
602              */
603
604             if (PL_preprocess && !PL_in_eval)
605                 (void)PerlProc_pclose(PL_rsfp);
606             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
607                 PerlIO_clearerr(PL_rsfp);
608             else
609                 (void)PerlIO_close(PL_rsfp);
610             PL_rsfp = Nullfp;
611             return s;
612         }
613
614         /* not at end of file, so we only read another line */
615         /* make corresponding updates to old pointers, for yyerror() */
616         oldprevlen = PL_oldbufptr - PL_bufend;
617         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
618         if (PL_last_uni)
619             oldunilen = PL_last_uni - PL_bufend;
620         if (PL_last_lop)
621             oldloplen = PL_last_lop - PL_bufend;
622         PL_linestart = PL_bufptr = s + prevlen;
623         PL_bufend = s + SvCUR(PL_linestr);
624         s = PL_bufptr;
625         PL_oldbufptr = s + oldprevlen;
626         PL_oldoldbufptr = s + oldoldprevlen;
627         if (PL_last_uni)
628             PL_last_uni = s + oldunilen;
629         if (PL_last_lop)
630             PL_last_lop = s + oldloplen;
631         incline(s);
632
633         /* debugger active and we're not compiling the debugger code,
634          * so store the line into the debugger's array of lines
635          */
636         if (PERLDB_LINE && PL_curstash != PL_debstash) {
637             SV *sv = NEWSV(85,0);
638
639             sv_upgrade(sv, SVt_PVMG);
640             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
641             (void)SvIOK_on(sv);
642             SvIVX(sv) = 0;
643             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
644         }
645     }
646 }
647
648 /*
649  * S_check_uni
650  * Check the unary operators to ensure there's no ambiguity in how they're
651  * used.  An ambiguous piece of code would be:
652  *     rand + 5
653  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
654  * the +5 is its argument.
655  */
656
657 STATIC void
658 S_check_uni(pTHX)
659 {
660     char *s;
661     char *t;
662
663     if (PL_oldoldbufptr != PL_last_uni)
664         return;
665     while (isSPACE(*PL_last_uni))
666         PL_last_uni++;
667     for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
668     if ((t = strchr(s, '(')) && t < PL_bufptr)
669         return;
670     if (ckWARN_d(WARN_AMBIGUOUS)){
671         char ch = *s;
672         *s = '\0';
673         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
674                    "Warning: Use of \"%s\" without parentheses is ambiguous",
675                    PL_last_uni);
676         *s = ch;
677     }
678 }
679
680 /*
681  * LOP : macro to build a list operator.  Its behaviour has been replaced
682  * with a subroutine, S_lop() for which LOP is just another name.
683  */
684
685 #define LOP(f,x) return lop(f,x,s)
686
687 /*
688  * S_lop
689  * Build a list operator (or something that might be one).  The rules:
690  *  - if we have a next token, then it's a list operator [why?]
691  *  - if the next thing is an opening paren, then it's a function
692  *  - else it's a list operator
693  */
694
695 STATIC I32
696 S_lop(pTHX_ I32 f, int x, char *s)
697 {
698     yylval.ival = f;
699     CLINE;
700     REPORT("lop", f)
701     PL_expect = x;
702     PL_bufptr = s;
703     PL_last_lop = PL_oldbufptr;
704     PL_last_lop_op = (OPCODE)f;
705     if (PL_nexttoke)
706         return LSTOP;
707     if (*s == '(')
708         return FUNC;
709     s = skipspace(s);
710     if (*s == '(')
711         return FUNC;
712     else
713         return LSTOP;
714 }
715
716 /*
717  * S_force_next
718  * When the lexer realizes it knows the next token (for instance,
719  * it is reordering tokens for the parser) then it can call S_force_next
720  * to know what token to return the next time the lexer is called.  Caller
721  * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
722  * handles the token correctly.
723  */
724
725 STATIC void
726 S_force_next(pTHX_ I32 type)
727 {
728     PL_nexttype[PL_nexttoke] = type;
729     PL_nexttoke++;
730     if (PL_lex_state != LEX_KNOWNEXT) {
731         PL_lex_defer = PL_lex_state;
732         PL_lex_expect = PL_expect;
733         PL_lex_state = LEX_KNOWNEXT;
734     }
735 }
736
737 /*
738  * S_force_word
739  * When the lexer knows the next thing is a word (for instance, it has
740  * just seen -> and it knows that the next char is a word char, then
741  * it calls S_force_word to stick the next word into the PL_next lookahead.
742  *
743  * Arguments:
744  *   char *start : buffer position (must be within PL_linestr)
745  *   int token   : PL_next will be this type of bare word (e.g., METHOD,WORD)
746  *   int check_keyword : if true, Perl checks to make sure the word isn't
747  *       a keyword (do this if the word is a label, e.g. goto FOO)
748  *   int allow_pack : if true, : characters will also be allowed (require,
749  *       use, etc. do this)
750  *   int allow_initial_tick : used by the "sub" lexer only.
751  */
752
753 STATIC char *
754 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
755 {
756     register char *s;
757     STRLEN len;
758
759     start = skipspace(start);
760     s = start;
761     if (isIDFIRST_lazy_if(s,UTF) ||
762         (allow_pack && *s == ':') ||
763         (allow_initial_tick && *s == '\'') )
764     {
765         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
766         if (check_keyword && keyword(PL_tokenbuf, len))
767             return start;
768         if (token == METHOD) {
769             s = skipspace(s);
770             if (*s == '(')
771                 PL_expect = XTERM;
772             else {
773                 PL_expect = XOPERATOR;
774             }
775         }
776         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
777         PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
778         if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
779             SvUTF8_on(((SVOP*)PL_nextval[PL_nexttoke].opval)->op_sv);
780         force_next(token);
781     }
782     return s;
783 }
784
785 /*
786  * S_force_ident
787  * Called when the lexer wants $foo *foo &foo etc, but the program
788  * text only contains the "foo" portion.  The first argument is a pointer
789  * to the "foo", and the second argument is the type symbol to prefix.
790  * Forces the next token to be a "WORD".
791  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
792  */
793
794 STATIC void
795 S_force_ident(pTHX_ register char *s, int kind)
796 {
797     if (s && *s) {
798         OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
799         PL_nextval[PL_nexttoke].opval = o;
800         force_next(WORD);
801         if (kind) {
802             o->op_private = OPpCONST_ENTERED;
803             /* XXX see note in pp_entereval() for why we forgo typo
804                warnings if the symbol must be introduced in an eval.
805                GSAR 96-10-12 */
806             gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
807                 kind == '$' ? SVt_PV :
808                 kind == '@' ? SVt_PVAV :
809                 kind == '%' ? SVt_PVHV :
810                               SVt_PVGV
811                 );
812         }
813     }
814 }
815
816 NV
817 Perl_str_to_version(pTHX_ SV *sv)
818 {
819     NV retval = 0.0;
820     NV nshift = 1.0;
821     STRLEN len;
822     char *start = SvPVx(sv,len);
823     bool utf = SvUTF8(sv) ? TRUE : FALSE;
824     char *end = start + len;
825     while (start < end) {
826         STRLEN skip;
827         UV n;
828         if (utf)
829             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
830         else {
831             n = *(U8*)start;
832             skip = 1;
833         }
834         retval += ((NV)n)/nshift;
835         start += skip;
836         nshift *= 1000;
837     }
838     return retval;
839 }
840
841 /*
842  * S_force_version
843  * Forces the next token to be a version number.
844  * If the next token appears to be an invalid version number, (e.g. "v2b"),
845  * and if "guessing" is TRUE, then no new token is created (and the caller
846  * must use an alternative parsing method).
847  */
848
849 STATIC char *
850 S_force_version(pTHX_ char *s, int guessing)
851 {
852     OP *version = Nullop;
853     char *d;
854
855     s = skipspace(s);
856
857     d = s;
858     if (*d == 'v')
859         d++;
860     if (isDIGIT(*d)) {
861         while (isDIGIT(*d) || *d == '_' || *d == '.')
862             d++;
863         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
864             SV *ver;
865             s = scan_num(s, &yylval);
866             version = yylval.opval;
867             ver = cSVOPx(version)->op_sv;
868             if (SvPOK(ver) && !SvNIOK(ver)) {
869                 (void)SvUPGRADE(ver, SVt_PVNV);
870                 SvNVX(ver) = str_to_version(ver);
871                 SvNOK_on(ver);          /* hint that it is a version */
872             }
873         }
874         else if (guessing)
875             return s;
876     }
877
878     /* NOTE: The parser sees the package name and the VERSION swapped */
879     PL_nextval[PL_nexttoke].opval = version;
880     force_next(WORD);
881
882     return s;
883 }
884
885 /*
886  * S_tokeq
887  * Tokenize a quoted string passed in as an SV.  It finds the next
888  * chunk, up to end of string or a backslash.  It may make a new
889  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
890  * turns \\ into \.
891  */
892
893 STATIC SV *
894 S_tokeq(pTHX_ SV *sv)
895 {
896     register char *s;
897     register char *send;
898     register char *d;
899     STRLEN len = 0;
900     SV *pv = sv;
901
902     if (!SvLEN(sv))
903         goto finish;
904
905     s = SvPV_force(sv, len);
906     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
907         goto finish;
908     send = s + len;
909     while (s < send && *s != '\\')
910         s++;
911     if (s == send)
912         goto finish;
913     d = s;
914     if ( PL_hints & HINT_NEW_STRING ) {
915         pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
916         if (SvUTF8(sv))
917             SvUTF8_on(pv);
918     }
919     while (s < send) {
920         if (*s == '\\') {
921             if (s + 1 < send && (s[1] == '\\'))
922                 s++;            /* all that, just for this */
923         }
924         *d++ = *s++;
925     }
926     *d = '\0';
927     SvCUR_set(sv, d - SvPVX(sv));
928   finish:
929     if ( PL_hints & HINT_NEW_STRING )
930        return new_constant(NULL, 0, "q", sv, pv, "q");
931     return sv;
932 }
933
934 /*
935  * Now come three functions related to double-quote context,
936  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
937  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
938  * interact with PL_lex_state, and create fake ( ... ) argument lists
939  * to handle functions and concatenation.
940  * They assume that whoever calls them will be setting up a fake
941  * join call, because each subthing puts a ',' after it.  This lets
942  *   "lower \luPpEr"
943  * become
944  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
945  *
946  * (I'm not sure whether the spurious commas at the end of lcfirst's
947  * arguments and join's arguments are created or not).
948  */
949
950 /*
951  * S_sublex_start
952  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
953  *
954  * Pattern matching will set PL_lex_op to the pattern-matching op to
955  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
956  *
957  * OP_CONST and OP_READLINE are easy--just make the new op and return.
958  *
959  * Everything else becomes a FUNC.
960  *
961  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
962  * had an OP_CONST or OP_READLINE).  This just sets us up for a
963  * call to S_sublex_push().
964  */
965
966 STATIC I32
967 S_sublex_start(pTHX)
968 {
969     register I32 op_type = yylval.ival;
970
971     if (op_type == OP_NULL) {
972         yylval.opval = PL_lex_op;
973         PL_lex_op = Nullop;
974         return THING;
975     }
976     if (op_type == OP_CONST || op_type == OP_READLINE) {
977         SV *sv = tokeq(PL_lex_stuff);
978
979         if (SvTYPE(sv) == SVt_PVIV) {
980             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
981             STRLEN len;
982             char *p;
983             SV *nsv;
984
985             p = SvPV(sv, len);
986             nsv = newSVpvn(p, len);
987             if (SvUTF8(sv))
988                 SvUTF8_on(nsv);
989             SvREFCNT_dec(sv);
990             sv = nsv;
991         }
992         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
993         PL_lex_stuff = Nullsv;
994         /* Allow <FH> // "foo" */
995         if (op_type == OP_READLINE)
996             PL_expect = XTERMORDORDOR;
997         return THING;
998     }
999
1000     PL_sublex_info.super_state = PL_lex_state;
1001     PL_sublex_info.sub_inwhat = op_type;
1002     PL_sublex_info.sub_op = PL_lex_op;
1003     PL_lex_state = LEX_INTERPPUSH;
1004
1005     PL_expect = XTERM;
1006     if (PL_lex_op) {
1007         yylval.opval = PL_lex_op;
1008         PL_lex_op = Nullop;
1009         return PMFUNC;
1010     }
1011     else
1012         return FUNC;
1013 }
1014
1015 /*
1016  * S_sublex_push
1017  * Create a new scope to save the lexing state.  The scope will be
1018  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1019  * to the uc, lc, etc. found before.
1020  * Sets PL_lex_state to LEX_INTERPCONCAT.
1021  */
1022
1023 STATIC I32
1024 S_sublex_push(pTHX)
1025 {
1026     ENTER;
1027
1028     PL_lex_state = PL_sublex_info.super_state;
1029     SAVEI32(PL_lex_dojoin);
1030     SAVEI32(PL_lex_brackets);
1031     SAVEI32(PL_lex_casemods);
1032     SAVEI32(PL_lex_starts);
1033     SAVEI32(PL_lex_state);
1034     SAVEVPTR(PL_lex_inpat);
1035     SAVEI32(PL_lex_inwhat);
1036     SAVECOPLINE(PL_curcop);
1037     SAVEPPTR(PL_bufptr);
1038     SAVEPPTR(PL_bufend);
1039     SAVEPPTR(PL_oldbufptr);
1040     SAVEPPTR(PL_oldoldbufptr);
1041     SAVEPPTR(PL_last_lop);
1042     SAVEPPTR(PL_last_uni);
1043     SAVEPPTR(PL_linestart);
1044     SAVESPTR(PL_linestr);
1045     SAVEGENERICPV(PL_lex_brackstack);
1046     SAVEGENERICPV(PL_lex_casestack);
1047
1048     PL_linestr = PL_lex_stuff;
1049     PL_lex_stuff = Nullsv;
1050
1051     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1052         = SvPVX(PL_linestr);
1053     PL_bufend += SvCUR(PL_linestr);
1054     PL_last_lop = PL_last_uni = Nullch;
1055     SAVEFREESV(PL_linestr);
1056
1057     PL_lex_dojoin = FALSE;
1058     PL_lex_brackets = 0;
1059     New(899, PL_lex_brackstack, 120, char);
1060     New(899, PL_lex_casestack, 12, char);
1061     PL_lex_casemods = 0;
1062     *PL_lex_casestack = '\0';
1063     PL_lex_starts = 0;
1064     PL_lex_state = LEX_INTERPCONCAT;
1065     CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1066
1067     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1068     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1069         PL_lex_inpat = PL_sublex_info.sub_op;
1070     else
1071         PL_lex_inpat = Nullop;
1072
1073     return '(';
1074 }
1075
1076 /*
1077  * S_sublex_done
1078  * Restores lexer state after a S_sublex_push.
1079  */
1080
1081 STATIC I32
1082 S_sublex_done(pTHX)
1083 {
1084     if (!PL_lex_starts++) {
1085         SV *sv = newSVpvn("",0);
1086         if (SvUTF8(PL_linestr))
1087             SvUTF8_on(sv);
1088         PL_expect = XOPERATOR;
1089         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1090         return THING;
1091     }
1092
1093     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1094         PL_lex_state = LEX_INTERPCASEMOD;
1095         return yylex();
1096     }
1097
1098     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1099     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1100         PL_linestr = PL_lex_repl;
1101         PL_lex_inpat = 0;
1102         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1103         PL_bufend += SvCUR(PL_linestr);
1104         PL_last_lop = PL_last_uni = Nullch;
1105         SAVEFREESV(PL_linestr);
1106         PL_lex_dojoin = FALSE;
1107         PL_lex_brackets = 0;
1108         PL_lex_casemods = 0;
1109         *PL_lex_casestack = '\0';
1110         PL_lex_starts = 0;
1111         if (SvEVALED(PL_lex_repl)) {
1112             PL_lex_state = LEX_INTERPNORMAL;
1113             PL_lex_starts++;
1114             /*  we don't clear PL_lex_repl here, so that we can check later
1115                 whether this is an evalled subst; that means we rely on the
1116                 logic to ensure sublex_done() is called again only via the
1117                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1118         }
1119         else {
1120             PL_lex_state = LEX_INTERPCONCAT;
1121             PL_lex_repl = Nullsv;
1122         }
1123         return ',';
1124     }
1125     else {
1126         LEAVE;
1127         PL_bufend = SvPVX(PL_linestr);
1128         PL_bufend += SvCUR(PL_linestr);
1129         PL_expect = XOPERATOR;
1130         PL_sublex_info.sub_inwhat = 0;
1131         return ')';
1132     }
1133 }
1134
1135 /*
1136   scan_const
1137
1138   Extracts a pattern, double-quoted string, or transliteration.  This
1139   is terrifying code.
1140
1141   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1142   processing a pattern (PL_lex_inpat is true), a transliteration
1143   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1144
1145   Returns a pointer to the character scanned up to. Iff this is
1146   advanced from the start pointer supplied (ie if anything was
1147   successfully parsed), will leave an OP for the substring scanned
1148   in yylval. Caller must intuit reason for not parsing further
1149   by looking at the next characters herself.
1150
1151   In patterns:
1152     backslashes:
1153       double-quoted style: \r and \n
1154       regexp special ones: \D \s
1155       constants: \x3
1156       backrefs: \1 (deprecated in substitution replacements)
1157       case and quoting: \U \Q \E
1158     stops on @ and $, but not for $ as tail anchor
1159
1160   In transliterations:
1161     characters are VERY literal, except for - not at the start or end
1162     of the string, which indicates a range.  scan_const expands the
1163     range to the full set of intermediate characters.
1164
1165   In double-quoted strings:
1166     backslashes:
1167       double-quoted style: \r and \n
1168       constants: \x3
1169       backrefs: \1 (deprecated)
1170       case and quoting: \U \Q \E
1171     stops on @ and $
1172
1173   scan_const does *not* construct ops to handle interpolated strings.
1174   It stops processing as soon as it finds an embedded $ or @ variable
1175   and leaves it to the caller to work out what's going on.
1176
1177   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1178
1179   $ in pattern could be $foo or could be tail anchor.  Assumption:
1180   it's a tail anchor if $ is the last thing in the string, or if it's
1181   followed by one of ")| \n\t"
1182
1183   \1 (backreferences) are turned into $1
1184
1185   The structure of the code is
1186       while (there's a character to process) {
1187           handle transliteration ranges
1188           skip regexp comments
1189           skip # initiated comments in //x patterns
1190           check for embedded @foo
1191           check for embedded scalars
1192           if (backslash) {
1193               leave intact backslashes from leave (below)
1194               deprecate \1 in strings and sub replacements
1195               handle string-changing backslashes \l \U \Q \E, etc.
1196               switch (what was escaped) {
1197                   handle - in a transliteration (becomes a literal -)
1198                   handle \132 octal characters
1199                   handle 0x15 hex characters
1200                   handle \cV (control V)
1201                   handle printf backslashes (\f, \r, \n, etc)
1202               } (end switch)
1203           } (end if backslash)
1204     } (end while character to read)
1205                 
1206 */
1207
1208 STATIC char *
1209 S_scan_const(pTHX_ char *start)
1210 {
1211     register char *send = PL_bufend;            /* end of the constant */
1212     SV *sv = NEWSV(93, send - start);           /* sv for the constant */
1213     register char *s = start;                   /* start of the constant */
1214     register char *d = SvPVX(sv);               /* destination for copies */
1215     bool dorange = FALSE;                       /* are we in a translit range? */
1216     bool didrange = FALSE;                      /* did we just finish a range? */
1217     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1218     I32  this_utf8 = UTF;                       /* The source string is assumed to be UTF8 */
1219     UV uv;
1220
1221     const char *leaveit =       /* set of acceptably-backslashed characters */
1222         PL_lex_inpat
1223             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#"
1224             : "";
1225
1226     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1227         /* If we are doing a trans and we know we want UTF8 set expectation */
1228         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1229         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1230     }
1231
1232
1233     while (s < send || dorange) {
1234         /* get transliterations out of the way (they're most literal) */
1235         if (PL_lex_inwhat == OP_TRANS) {
1236             /* expand a range A-Z to the full set of characters.  AIE! */
1237             if (dorange) {
1238                 I32 i;                          /* current expanded character */
1239                 I32 min;                        /* first character in range */
1240                 I32 max;                        /* last character in range */
1241
1242                 if (has_utf8) {
1243                     char *c = (char*)utf8_hop((U8*)d, -1);
1244                     char *e = d++;
1245                     while (e-- > c)
1246                         *(e + 1) = *e;
1247                     *c = (char)UTF_TO_NATIVE(0xff);
1248                     /* mark the range as done, and continue */
1249                     dorange = FALSE;
1250                     didrange = TRUE;
1251                     continue;
1252                 }
1253
1254                 i = d - SvPVX(sv);              /* remember current offset */
1255                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1256                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1257                 d -= 2;                         /* eat the first char and the - */
1258
1259                 min = (U8)*d;                   /* first char in range */
1260                 max = (U8)d[1];                 /* last char in range  */
1261
1262                 if (min > max) {
1263                     Perl_croak(aTHX_
1264                                "Invalid range \"%c-%c\" in transliteration operator",
1265                                (char)min, (char)max);
1266                 }
1267
1268 #ifdef EBCDIC
1269                 if ((isLOWER(min) && isLOWER(max)) ||
1270                     (isUPPER(min) && isUPPER(max))) {
1271                     if (isLOWER(min)) {
1272                         for (i = min; i <= max; i++)
1273                             if (isLOWER(i))
1274                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1275                     } else {
1276                         for (i = min; i <= max; i++)
1277                             if (isUPPER(i))
1278                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1279                     }
1280                 }
1281                 else
1282 #endif
1283                     for (i = min; i <= max; i++)
1284                         *d++ = (char)i;
1285
1286                 /* mark the range as done, and continue */
1287                 dorange = FALSE;
1288                 didrange = TRUE;
1289                 continue;
1290             }
1291
1292             /* range begins (ignore - as first or last char) */
1293             else if (*s == '-' && s+1 < send  && s != start) {
1294                 if (didrange) {
1295                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1296                 }
1297                 if (has_utf8) {
1298                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
1299                     s++;
1300                     continue;
1301                 }
1302                 dorange = TRUE;
1303                 s++;
1304             }
1305             else {
1306                 didrange = FALSE;
1307             }
1308         }
1309
1310         /* if we get here, we're not doing a transliteration */
1311
1312         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1313            except for the last char, which will be done separately. */
1314         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1315             if (s[2] == '#') {
1316                 while (s+1 < send && *s != ')')
1317                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1318             }
1319             else if (s[2] == '{' /* This should match regcomp.c */
1320                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1321             {
1322                 I32 count = 1;
1323                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1324                 char c;
1325
1326                 while (count && (c = *regparse)) {
1327                     if (c == '\\' && regparse[1])
1328                         regparse++;
1329                     else if (c == '{')
1330                         count++;
1331                     else if (c == '}')
1332                         count--;
1333                     regparse++;
1334                 }
1335                 if (*regparse != ')')
1336                     regparse--;         /* Leave one char for continuation. */
1337                 while (s < regparse)
1338                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1339             }
1340         }
1341
1342         /* likewise skip #-initiated comments in //x patterns */
1343         else if (*s == '#' && PL_lex_inpat &&
1344           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1345             while (s+1 < send && *s != '\n')
1346                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1347         }
1348
1349         /* check for embedded arrays
1350            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1351            */
1352         else if (*s == '@' && s[1]
1353                  && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1354             break;
1355
1356         /* check for embedded scalars.  only stop if we're sure it's a
1357            variable.
1358         */
1359         else if (*s == '$') {
1360             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1361                 break;
1362             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1363                 break;          /* in regexp, $ might be tail anchor */
1364         }
1365
1366         /* End of else if chain - OP_TRANS rejoin rest */
1367
1368         /* backslashes */
1369         if (*s == '\\' && s+1 < send) {
1370             s++;
1371
1372             /* some backslashes we leave behind */
1373             if (*leaveit && *s && strchr(leaveit, *s)) {
1374                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1375                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1376                 continue;
1377             }
1378
1379             /* deprecate \1 in strings and substitution replacements */
1380             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1381                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1382             {
1383                 if (ckWARN(WARN_SYNTAX))
1384                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1385                 *--s = '$';
1386                 break;
1387             }
1388
1389             /* string-change backslash escapes */
1390             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1391                 --s;
1392                 break;
1393             }
1394
1395             /* if we get here, it's either a quoted -, or a digit */
1396             switch (*s) {
1397
1398             /* quoted - in transliterations */
1399             case '-':
1400                 if (PL_lex_inwhat == OP_TRANS) {
1401                     *d++ = *s++;
1402                     continue;
1403                 }
1404                 /* FALL THROUGH */
1405             default:
1406                 {
1407                     if (ckWARN(WARN_MISC) &&
1408                         isALNUM(*s) && 
1409                         *s != '_')
1410                         Perl_warner(aTHX_ packWARN(WARN_MISC),
1411                                "Unrecognized escape \\%c passed through",
1412                                *s);
1413                     /* default action is to copy the quoted character */
1414                     goto default_action;
1415                 }
1416
1417             /* \132 indicates an octal constant */
1418             case '0': case '1': case '2': case '3':
1419             case '4': case '5': case '6': case '7':
1420                 {
1421                     I32 flags = 0;
1422                     STRLEN len = 3;
1423                     uv = grok_oct(s, &len, &flags, NULL);
1424                     s += len;
1425                 }
1426                 goto NUM_ESCAPE_INSERT;
1427
1428             /* \x24 indicates a hex constant */
1429             case 'x':
1430                 ++s;
1431                 if (*s == '{') {
1432                     char* e = strchr(s, '}');
1433                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1434                       PERL_SCAN_DISALLOW_PREFIX;
1435                     STRLEN len;
1436
1437                     ++s;
1438                     if (!e) {
1439                         yyerror("Missing right brace on \\x{}");
1440                         continue;
1441                     }
1442                     len = e - s;
1443                     uv = grok_hex(s, &len, &flags, NULL);
1444                     s = e + 1;
1445                 }
1446                 else {
1447                     {
1448                         STRLEN len = 2;
1449                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1450                         uv = grok_hex(s, &len, &flags, NULL);
1451                         s += len;
1452                     }
1453                 }
1454
1455               NUM_ESCAPE_INSERT:
1456                 /* Insert oct or hex escaped character.
1457                  * There will always enough room in sv since such
1458                  * escapes will be longer than any UTF-8 sequence
1459                  * they can end up as. */
1460                 
1461                 /* We need to map to chars to ASCII before doing the tests
1462                    to cover EBCDIC
1463                 */
1464                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1465                     if (!has_utf8 && uv > 255) {
1466                         /* Might need to recode whatever we have
1467                          * accumulated so far if it contains any
1468                          * hibit chars.
1469                          *
1470                          * (Can't we keep track of that and avoid
1471                          *  this rescan? --jhi)
1472                          */
1473                         int hicount = 0;
1474                         U8 *c;
1475                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1476                             if (!NATIVE_IS_INVARIANT(*c)) {
1477                                 hicount++;
1478                             }
1479                         }
1480                         if (hicount) {
1481                             STRLEN offset = d - SvPVX(sv);
1482                             U8 *src, *dst;
1483                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1484                             src = (U8 *)d - 1;
1485                             dst = src+hicount;
1486                             d  += hicount;
1487                             while (src >= (U8 *)SvPVX(sv)) {
1488                                 if (!NATIVE_IS_INVARIANT(*src)) {
1489                                     U8 ch = NATIVE_TO_ASCII(*src);
1490                                     *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1491                                     *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1492                                 }
1493                                 else {
1494                                     *dst-- = *src;
1495                                 }
1496                                 src--;
1497                             }
1498                         }
1499                     }
1500
1501                     if (has_utf8 || uv > 255) {
1502                         d = (char*)uvchr_to_utf8((U8*)d, uv);
1503                         has_utf8 = TRUE;
1504                         if (PL_lex_inwhat == OP_TRANS &&
1505                             PL_sublex_info.sub_op) {
1506                             PL_sublex_info.sub_op->op_private |=
1507                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
1508                                              : OPpTRANS_TO_UTF);
1509                         }
1510                     }
1511                     else {
1512                         *d++ = (char)uv;
1513                     }
1514                 }
1515                 else {
1516                     *d++ = (char) uv;
1517                 }
1518                 continue;
1519
1520             /* \N{LATIN SMALL LETTER A} is a named character */
1521             case 'N':
1522                 ++s;
1523                 if (*s == '{') {
1524                     char* e = strchr(s, '}');
1525                     SV *res;
1526                     STRLEN len;
1527                     char *str;
1528
1529                     if (!e) {
1530                         yyerror("Missing right brace on \\N{}");
1531                         e = s - 1;
1532                         goto cont_scan;
1533                     }
1534                     if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1535                         /* \N{U+...} */
1536                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1537                           PERL_SCAN_DISALLOW_PREFIX;
1538                         s += 3;
1539                         len = e - s;
1540                         uv = grok_hex(s, &len, &flags, NULL);
1541                         s = e + 1;
1542                         goto NUM_ESCAPE_INSERT;
1543                     }
1544                     res = newSVpvn(s + 1, e - s - 1);
1545                     res = new_constant( Nullch, 0, "charnames",
1546                                         res, Nullsv, "\\N{...}" );
1547                     if (has_utf8)
1548                         sv_utf8_upgrade(res);
1549                     str = SvPV(res,len);
1550 #ifdef EBCDIC_NEVER_MIND
1551                     /* charnames uses pack U and that has been
1552                      * recently changed to do the below uni->native
1553                      * mapping, so this would be redundant (and wrong,
1554                      * the code point would be doubly converted).
1555                      * But leave this in just in case the pack U change
1556                      * gets revoked, but the semantics is still
1557                      * desireable for charnames. --jhi */
1558                     {
1559                          UV uv = utf8_to_uvchr((U8*)str, 0);
1560
1561                          if (uv < 0x100) {
1562                               U8 tmpbuf[UTF8_MAXLEN+1], *d;
1563
1564                               d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1565                               sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1566                               str = SvPV(res, len);
1567                          }
1568                     }
1569 #endif
1570                     if (!has_utf8 && SvUTF8(res)) {
1571                         char *ostart = SvPVX(sv);
1572                         SvCUR_set(sv, d - ostart);
1573                         SvPOK_on(sv);
1574                         *d = '\0';
1575                         sv_utf8_upgrade(sv);
1576                         /* this just broke our allocation above... */
1577                         SvGROW(sv, (STRLEN)(send - start));
1578                         d = SvPVX(sv) + SvCUR(sv);
1579                         has_utf8 = TRUE;
1580                     }
1581                     if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1582                         char *odest = SvPVX(sv);
1583
1584                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1585                         d = SvPVX(sv) + (d - odest);
1586                     }
1587                     Copy(str, d, len, char);
1588                     d += len;
1589                     SvREFCNT_dec(res);
1590                   cont_scan:
1591                     s = e + 1;
1592                 }
1593                 else
1594                     yyerror("Missing braces on \\N{}");
1595                 continue;
1596
1597             /* \c is a control character */
1598             case 'c':
1599                 s++;
1600                 if (s < send) {
1601                     U8 c = *s++;
1602 #ifdef EBCDIC
1603                     if (isLOWER(c))
1604                         c = toUPPER(c);
1605 #endif
1606                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1607                 }
1608                 else {
1609                     yyerror("Missing control char name in \\c");
1610                 }
1611                 continue;
1612
1613             /* printf-style backslashes, formfeeds, newlines, etc */
1614             case 'b':
1615                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1616                 break;
1617             case 'n':
1618                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1619                 break;
1620             case 'r':
1621                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1622                 break;
1623             case 'f':
1624                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1625                 break;
1626             case 't':
1627                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1628                 break;
1629             case 'e':
1630                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1631                 break;
1632             case 'a':
1633                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1634                 break;
1635             } /* end switch */
1636
1637             s++;
1638             continue;
1639         } /* end if (backslash) */
1640
1641     default_action:
1642         /* If we started with encoded form, or already know we want it
1643            and then encode the next character */
1644         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1645             STRLEN len  = 1;
1646             UV uv       = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1647             STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1648             s += len;
1649             if (need > len) {
1650                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1651                 STRLEN off = d - SvPVX(sv);
1652                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1653             }
1654             d = (char*)uvchr_to_utf8((U8*)d, uv);
1655             has_utf8 = TRUE;
1656         }
1657         else {
1658             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1659         }
1660     } /* while loop to process each character */
1661
1662     /* terminate the string and set up the sv */
1663     *d = '\0';
1664     SvCUR_set(sv, d - SvPVX(sv));
1665     if (SvCUR(sv) >= SvLEN(sv))
1666         Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1667
1668     SvPOK_on(sv);
1669     if (PL_encoding && !has_utf8) {
1670         sv_recode_to_utf8(sv, PL_encoding);
1671         if (SvUTF8(sv))
1672             has_utf8 = TRUE;
1673     }
1674     if (has_utf8) {
1675         SvUTF8_on(sv);
1676         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1677             PL_sublex_info.sub_op->op_private |=
1678                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1679         }
1680     }
1681
1682     /* shrink the sv if we allocated more than we used */
1683     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1684         SvLEN_set(sv, SvCUR(sv) + 1);
1685         Renew(SvPVX(sv), SvLEN(sv), char);
1686     }
1687
1688     /* return the substring (via yylval) only if we parsed anything */
1689     if (s > PL_bufptr) {
1690         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1691             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1692                               sv, Nullsv,
1693                               ( PL_lex_inwhat == OP_TRANS
1694                                 ? "tr"
1695                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1696                                     ? "s"
1697                                     : "qq")));
1698         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1699     } else
1700         SvREFCNT_dec(sv);
1701     return s;
1702 }
1703
1704 /* S_intuit_more
1705  * Returns TRUE if there's more to the expression (e.g., a subscript),
1706  * FALSE otherwise.
1707  *
1708  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1709  *
1710  * ->[ and ->{ return TRUE
1711  * { and [ outside a pattern are always subscripts, so return TRUE
1712  * if we're outside a pattern and it's not { or [, then return FALSE
1713  * if we're in a pattern and the first char is a {
1714  *   {4,5} (any digits around the comma) returns FALSE
1715  * if we're in a pattern and the first char is a [
1716  *   [] returns FALSE
1717  *   [SOMETHING] has a funky algorithm to decide whether it's a
1718  *      character class or not.  It has to deal with things like
1719  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1720  * anything else returns TRUE
1721  */
1722
1723 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1724
1725 STATIC int
1726 S_intuit_more(pTHX_ register char *s)
1727 {
1728     if (PL_lex_brackets)
1729         return TRUE;
1730     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1731         return TRUE;
1732     if (*s != '{' && *s != '[')
1733         return FALSE;
1734     if (!PL_lex_inpat)
1735         return TRUE;
1736
1737     /* In a pattern, so maybe we have {n,m}. */
1738     if (*s == '{') {
1739         s++;
1740         if (!isDIGIT(*s))
1741             return TRUE;
1742         while (isDIGIT(*s))
1743             s++;
1744         if (*s == ',')
1745             s++;
1746         while (isDIGIT(*s))
1747             s++;
1748         if (*s == '}')
1749             return FALSE;
1750         return TRUE;
1751         
1752     }
1753
1754     /* On the other hand, maybe we have a character class */
1755
1756     s++;
1757     if (*s == ']' || *s == '^')
1758         return FALSE;
1759     else {
1760         /* this is terrifying, and it works */
1761         int weight = 2;         /* let's weigh the evidence */
1762         char seen[256];
1763         unsigned char un_char = 255, last_un_char;
1764         char *send = strchr(s,']');
1765         char tmpbuf[sizeof PL_tokenbuf * 4];
1766
1767         if (!send)              /* has to be an expression */
1768             return TRUE;
1769
1770         Zero(seen,256,char);
1771         if (*s == '$')
1772             weight -= 3;
1773         else if (isDIGIT(*s)) {
1774             if (s[1] != ']') {
1775                 if (isDIGIT(s[1]) && s[2] == ']')
1776                     weight -= 10;
1777             }
1778             else
1779                 weight -= 100;
1780         }
1781         for (; s < send; s++) {
1782             last_un_char = un_char;
1783             un_char = (unsigned char)*s;
1784             switch (*s) {
1785             case '@':
1786             case '&':
1787             case '$':
1788                 weight -= seen[un_char] * 10;
1789                 if (isALNUM_lazy_if(s+1,UTF)) {
1790                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1791                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1792                         weight -= 100;
1793                     else
1794                         weight -= 10;
1795                 }
1796                 else if (*s == '$' && s[1] &&
1797                   strchr("[#!%*<>()-=",s[1])) {
1798                     if (/*{*/ strchr("])} =",s[2]))
1799                         weight -= 10;
1800                     else
1801                         weight -= 1;
1802                 }
1803                 break;
1804             case '\\':
1805                 un_char = 254;
1806                 if (s[1]) {
1807                     if (strchr("wds]",s[1]))
1808                         weight += 100;
1809                     else if (seen['\''] || seen['"'])
1810                         weight += 1;
1811                     else if (strchr("rnftbxcav",s[1]))
1812                         weight += 40;
1813                     else if (isDIGIT(s[1])) {
1814                         weight += 40;
1815                         while (s[1] && isDIGIT(s[1]))
1816                             s++;
1817                     }
1818                 }
1819                 else
1820                     weight += 100;
1821                 break;
1822             case '-':
1823                 if (s[1] == '\\')
1824                     weight += 50;
1825                 if (strchr("aA01! ",last_un_char))
1826                     weight += 30;
1827                 if (strchr("zZ79~",s[1]))
1828                     weight += 30;
1829                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1830                     weight -= 5;        /* cope with negative subscript */
1831                 break;
1832             default:
1833                 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1834                         isALPHA(*s) && s[1] && isALPHA(s[1])) {
1835                     char *d = tmpbuf;
1836                     while (isALPHA(*s))
1837                         *d++ = *s++;
1838                     *d = '\0';
1839                     if (keyword(tmpbuf, d - tmpbuf))
1840                         weight -= 150;
1841                 }
1842                 if (un_char == last_un_char + 1)
1843                     weight += 5;
1844                 weight -= seen[un_char];
1845                 break;
1846             }
1847             seen[un_char]++;
1848         }
1849         if (weight >= 0)        /* probably a character class */
1850             return FALSE;
1851     }
1852
1853     return TRUE;
1854 }
1855
1856 /*
1857  * S_intuit_method
1858  *
1859  * Does all the checking to disambiguate
1860  *   foo bar
1861  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
1862  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1863  *
1864  * First argument is the stuff after the first token, e.g. "bar".
1865  *
1866  * Not a method if bar is a filehandle.
1867  * Not a method if foo is a subroutine prototyped to take a filehandle.
1868  * Not a method if it's really "Foo $bar"
1869  * Method if it's "foo $bar"
1870  * Not a method if it's really "print foo $bar"
1871  * Method if it's really "foo package::" (interpreted as package->foo)
1872  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
1873  * Not a method if bar is a filehandle or package, but is quoted with
1874  *   =>
1875  */
1876
1877 STATIC int
1878 S_intuit_method(pTHX_ char *start, GV *gv)
1879 {
1880     char *s = start + (*start == '$');
1881     char tmpbuf[sizeof PL_tokenbuf];
1882     STRLEN len;
1883     GV* indirgv;
1884
1885     if (gv) {
1886         CV *cv;
1887         if (GvIO(gv))
1888             return 0;
1889         if ((cv = GvCVu(gv))) {
1890             char *proto = SvPVX(cv);
1891             if (proto) {
1892                 if (*proto == ';')
1893                     proto++;
1894                 if (*proto == '*')
1895                     return 0;
1896             }
1897         } else
1898             gv = 0;
1899     }
1900     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1901     /* start is the beginning of the possible filehandle/object,
1902      * and s is the end of it
1903      * tmpbuf is a copy of it
1904      */
1905
1906     if (*start == '$') {
1907         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1908             return 0;
1909         s = skipspace(s);
1910         PL_bufptr = start;
1911         PL_expect = XREF;
1912         return *s == '(' ? FUNCMETH : METHOD;
1913     }
1914     if (!keyword(tmpbuf, len)) {
1915         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1916             len -= 2;
1917             tmpbuf[len] = '\0';
1918             goto bare_package;
1919         }
1920         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1921         if (indirgv && GvCVu(indirgv))
1922             return 0;
1923         /* filehandle or package name makes it a method */
1924         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1925             s = skipspace(s);
1926             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1927                 return 0;       /* no assumptions -- "=>" quotes bearword */
1928       bare_package:
1929             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1930                                                    newSVpvn(tmpbuf,len));
1931             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1932             PL_expect = XTERM;
1933             force_next(WORD);
1934             PL_bufptr = s;
1935             return *s == '(' ? FUNCMETH : METHOD;
1936         }
1937     }
1938     return 0;
1939 }
1940
1941 /*
1942  * S_incl_perldb
1943  * Return a string of Perl code to load the debugger.  If PERL5DB
1944  * is set, it will return the contents of that, otherwise a
1945  * compile-time require of perl5db.pl.
1946  */
1947
1948 STATIC char*
1949 S_incl_perldb(pTHX)
1950 {
1951     if (PL_perldb) {
1952         char *pdb = PerlEnv_getenv("PERL5DB");
1953
1954         if (pdb)
1955             return pdb;
1956         SETERRNO(0,SS_NORMAL);
1957         return "BEGIN { require 'perl5db.pl' }";
1958     }
1959     return "";
1960 }
1961
1962
1963 /* Encoded script support. filter_add() effectively inserts a
1964  * 'pre-processing' function into the current source input stream.
1965  * Note that the filter function only applies to the current source file
1966  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1967  *
1968  * The datasv parameter (which may be NULL) can be used to pass
1969  * private data to this instance of the filter. The filter function
1970  * can recover the SV using the FILTER_DATA macro and use it to
1971  * store private buffers and state information.
1972  *
1973  * The supplied datasv parameter is upgraded to a PVIO type
1974  * and the IoDIRP/IoANY field is used to store the function pointer,
1975  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1976  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1977  * private use must be set using malloc'd pointers.
1978  */
1979
1980 SV *
1981 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1982 {
1983     if (!funcp)
1984         return Nullsv;
1985
1986     if (!PL_rsfp_filters)
1987         PL_rsfp_filters = newAV();
1988     if (!datasv)
1989         datasv = NEWSV(255,0);
1990     if (!SvUPGRADE(datasv, SVt_PVIO))
1991         Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1992     IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1993     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1994     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1995                           (void*)funcp, SvPV_nolen(datasv)));
1996     av_unshift(PL_rsfp_filters, 1);
1997     av_store(PL_rsfp_filters, 0, datasv) ;
1998     return(datasv);
1999 }
2000
2001
2002 /* Delete most recently added instance of this filter function. */
2003 void
2004 Perl_filter_del(pTHX_ filter_t funcp)
2005 {
2006     SV *datasv;
2007     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
2008     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2009         return;
2010     /* if filter is on top of stack (usual case) just pop it off */
2011     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2012     if (IoANY(datasv) == (void *)funcp) {
2013         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2014         IoANY(datasv) = (void *)NULL;
2015         sv_free(av_pop(PL_rsfp_filters));
2016
2017         return;
2018     }
2019     /* we need to search for the correct entry and clear it     */
2020     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2021 }
2022
2023
2024 /* Invoke the n'th filter function for the current rsfp.         */
2025 I32
2026 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2027
2028
2029                         /* 0 = read one text line */
2030 {
2031     filter_t funcp;
2032     SV *datasv = NULL;
2033
2034     if (!PL_rsfp_filters)
2035         return -1;
2036     if (idx > AvFILLp(PL_rsfp_filters)){       /* Any more filters?     */
2037         /* Provide a default input filter to make life easy.    */
2038         /* Note that we append to the line. This is handy.      */
2039         DEBUG_P(PerlIO_printf(Perl_debug_log,
2040                               "filter_read %d: from rsfp\n", idx));
2041         if (maxlen) {
2042             /* Want a block */
2043             int len ;
2044             int old_len = SvCUR(buf_sv) ;
2045
2046             /* ensure buf_sv is large enough */
2047             SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2048             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2049                 if (PerlIO_error(PL_rsfp))
2050                     return -1;          /* error */
2051                 else
2052                     return 0 ;          /* end of file */
2053             }
2054             SvCUR_set(buf_sv, old_len + len) ;
2055         } else {
2056             /* Want a line */
2057             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2058                 if (PerlIO_error(PL_rsfp))
2059                     return -1;          /* error */
2060                 else
2061                     return 0 ;          /* end of file */
2062             }
2063         }
2064         return SvCUR(buf_sv);
2065     }
2066     /* Skip this filter slot if filter has been deleted */
2067     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2068         DEBUG_P(PerlIO_printf(Perl_debug_log,
2069                               "filter_read %d: skipped (filter deleted)\n",
2070                               idx));
2071         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2072     }
2073     /* Get function pointer hidden within datasv        */
2074     funcp = (filter_t)IoANY(datasv);
2075     DEBUG_P(PerlIO_printf(Perl_debug_log,
2076                           "filter_read %d: via function %p (%s)\n",
2077                           idx, (void*)funcp, SvPV_nolen(datasv)));
2078     /* Call function. The function is expected to       */
2079     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2080     /* Return: <0:error, =0:eof, >0:not eof             */
2081     return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2082 }
2083
2084 STATIC char *
2085 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2086 {
2087 #ifdef PERL_CR_FILTER
2088     if (!PL_rsfp_filters) {
2089         filter_add(S_cr_textfilter,NULL);
2090     }
2091 #endif
2092     if (PL_rsfp_filters) {
2093
2094         if (!append)
2095             SvCUR_set(sv, 0);   /* start with empty line        */
2096         if (FILTER_READ(0, sv, 0) > 0)
2097             return ( SvPVX(sv) ) ;
2098         else
2099             return Nullch ;
2100     }
2101     else
2102         return (sv_gets(sv, fp, append));
2103 }
2104
2105 STATIC HV *
2106 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2107 {
2108     GV *gv;
2109
2110     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2111         return PL_curstash;
2112
2113     if (len > 2 &&
2114         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2115         (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2116     {
2117         return GvHV(gv);                        /* Foo:: */
2118     }
2119
2120     /* use constant CLASS => 'MyClass' */
2121     if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2122         SV *sv;
2123         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2124             pkgname = SvPV_nolen(sv);
2125         }
2126     }
2127
2128     return gv_stashpv(pkgname, FALSE);
2129 }
2130
2131 #ifdef DEBUGGING
2132     static char* exp_name[] =
2133         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2134           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2135         };
2136 #endif
2137
2138 /*
2139   yylex
2140
2141   Works out what to call the token just pulled out of the input
2142   stream.  The yacc parser takes care of taking the ops we return and
2143   stitching them into a tree.
2144
2145   Returns:
2146     PRIVATEREF
2147
2148   Structure:
2149       if read an identifier
2150           if we're in a my declaration
2151               croak if they tried to say my($foo::bar)
2152               build the ops for a my() declaration
2153           if it's an access to a my() variable
2154               are we in a sort block?
2155                   croak if my($a); $a <=> $b
2156               build ops for access to a my() variable
2157           if in a dq string, and they've said @foo and we can't find @foo
2158               croak
2159           build ops for a bareword
2160       if we already built the token before, use it.
2161 */
2162
2163
2164 #ifdef __SC__
2165 #pragma segment Perl_yylex
2166 #endif
2167 int
2168 Perl_yylex(pTHX)
2169 {
2170     register char *s;
2171     register char *d;
2172     register I32 tmp;
2173     STRLEN len;
2174     GV *gv = Nullgv;
2175     GV **gvp = 0;
2176     bool bof = FALSE;
2177     I32 orig_keyword = 0;
2178
2179     /* check if there's an identifier for us to look at */
2180     if (PL_pending_ident)
2181         return S_pending_ident(aTHX);
2182
2183     /* no identifier pending identification */
2184
2185     switch (PL_lex_state) {
2186 #ifdef COMMENTARY
2187     case LEX_NORMAL:            /* Some compilers will produce faster */
2188     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2189         break;
2190 #endif
2191
2192     /* when we've already built the next token, just pull it out of the queue */
2193     case LEX_KNOWNEXT:
2194         PL_nexttoke--;
2195         yylval = PL_nextval[PL_nexttoke];
2196         if (!PL_nexttoke) {
2197             PL_lex_state = PL_lex_defer;
2198             PL_expect = PL_lex_expect;
2199             PL_lex_defer = LEX_NORMAL;
2200         }
2201         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2202               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2203               (IV)PL_nexttype[PL_nexttoke]); });
2204
2205         return(PL_nexttype[PL_nexttoke]);
2206
2207     /* interpolated case modifiers like \L \U, including \Q and \E.
2208        when we get here, PL_bufptr is at the \
2209     */
2210     case LEX_INTERPCASEMOD:
2211 #ifdef DEBUGGING
2212         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2213             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2214 #endif
2215         /* handle \E or end of string */
2216         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2217             char oldmod;
2218
2219             /* if at a \E */
2220             if (PL_lex_casemods) {
2221                 oldmod = PL_lex_casestack[--PL_lex_casemods];
2222                 PL_lex_casestack[PL_lex_casemods] = '\0';
2223
2224                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2225                     PL_bufptr += 2;
2226                     PL_lex_state = LEX_INTERPCONCAT;
2227                 }
2228                 return ')';
2229             }
2230             if (PL_bufptr != PL_bufend)
2231                 PL_bufptr += 2;
2232             PL_lex_state = LEX_INTERPCONCAT;
2233             return yylex();
2234         }
2235         else {
2236             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2237               "### Saw case modifier at '%s'\n", PL_bufptr); });
2238             s = PL_bufptr + 1;
2239             if (s[1] == '\\' && s[2] == 'E') {
2240                 PL_bufptr = s + 3;
2241                 PL_lex_state = LEX_INTERPCONCAT;
2242                 return yylex();
2243             }
2244             else {
2245                 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2246                     tmp = *s, *s = s[2], s[2] = (char)tmp;      /* misordered... */
2247                 if (strchr("LU", *s) &&
2248                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2249                     PL_lex_casestack[--PL_lex_casemods] = '\0';
2250                     return ')';
2251                 }
2252                 if (PL_lex_casemods > 10)
2253                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2254                 PL_lex_casestack[PL_lex_casemods++] = *s;
2255                 PL_lex_casestack[PL_lex_casemods] = '\0';
2256                 PL_lex_state = LEX_INTERPCONCAT;
2257                 PL_nextval[PL_nexttoke].ival = 0;
2258                 force_next('(');
2259                 if (*s == 'l')
2260                     PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2261                 else if (*s == 'u')
2262                     PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2263                 else if (*s == 'L')
2264                     PL_nextval[PL_nexttoke].ival = OP_LC;
2265                 else if (*s == 'U')
2266                     PL_nextval[PL_nexttoke].ival = OP_UC;
2267                 else if (*s == 'Q')
2268                     PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2269                 else
2270                     Perl_croak(aTHX_ "panic: yylex");
2271                 PL_bufptr = s + 1;
2272             }
2273             force_next(FUNC);
2274             if (PL_lex_starts) {
2275                 s = PL_bufptr;
2276                 PL_lex_starts = 0;
2277                 Aop(OP_CONCAT);
2278             }
2279             else
2280                 return yylex();
2281         }
2282
2283     case LEX_INTERPPUSH:
2284         return sublex_push();
2285
2286     case LEX_INTERPSTART:
2287         if (PL_bufptr == PL_bufend)
2288             return sublex_done();
2289         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2290               "### Interpolated variable at '%s'\n", PL_bufptr); });
2291         PL_expect = XTERM;
2292         PL_lex_dojoin = (*PL_bufptr == '@');
2293         PL_lex_state = LEX_INTERPNORMAL;
2294         if (PL_lex_dojoin) {
2295             PL_nextval[PL_nexttoke].ival = 0;
2296             force_next(',');
2297             force_ident("\"", '$');
2298             PL_nextval[PL_nexttoke].ival = 0;
2299             force_next('$');
2300             PL_nextval[PL_nexttoke].ival = 0;
2301             force_next('(');
2302             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2303             force_next(FUNC);
2304         }
2305         if (PL_lex_starts++) {
2306             s = PL_bufptr;
2307             Aop(OP_CONCAT);
2308         }
2309         return yylex();
2310
2311     case LEX_INTERPENDMAYBE:
2312         if (intuit_more(PL_bufptr)) {
2313             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2314             break;
2315         }
2316         /* FALL THROUGH */
2317
2318     case LEX_INTERPEND:
2319         if (PL_lex_dojoin) {
2320             PL_lex_dojoin = FALSE;
2321             PL_lex_state = LEX_INTERPCONCAT;
2322             return ')';
2323         }
2324         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2325             && SvEVALED(PL_lex_repl))
2326         {
2327             if (PL_bufptr != PL_bufend)
2328                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2329             PL_lex_repl = Nullsv;
2330         }
2331         /* FALLTHROUGH */
2332     case LEX_INTERPCONCAT:
2333 #ifdef DEBUGGING
2334         if (PL_lex_brackets)
2335             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2336 #endif
2337         if (PL_bufptr == PL_bufend)
2338             return sublex_done();
2339
2340         if (SvIVX(PL_linestr) == '\'') {
2341             SV *sv = newSVsv(PL_linestr);
2342             if (!PL_lex_inpat)
2343                 sv = tokeq(sv);
2344             else if ( PL_hints & HINT_NEW_RE )
2345                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2346             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2347             s = PL_bufend;
2348         }
2349         else {
2350             s = scan_const(PL_bufptr);
2351             if (*s == '\\')
2352                 PL_lex_state = LEX_INTERPCASEMOD;
2353             else
2354                 PL_lex_state = LEX_INTERPSTART;
2355         }
2356
2357         if (s != PL_bufptr) {
2358             PL_nextval[PL_nexttoke] = yylval;
2359             PL_expect = XTERM;
2360             force_next(THING);
2361             if (PL_lex_starts++)
2362                 Aop(OP_CONCAT);
2363             else {
2364                 PL_bufptr = s;
2365                 return yylex();
2366             }
2367         }
2368
2369         return yylex();
2370     case LEX_FORMLINE:
2371         PL_lex_state = LEX_NORMAL;
2372         s = scan_formline(PL_bufptr);
2373         if (!PL_lex_formbrack)
2374             goto rightbracket;
2375         OPERATOR(';');
2376     }
2377
2378     s = PL_bufptr;
2379     PL_oldoldbufptr = PL_oldbufptr;
2380     PL_oldbufptr = s;
2381     DEBUG_T( {
2382         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2383                       exp_name[PL_expect], s);
2384     } );
2385
2386   retry:
2387     switch (*s) {
2388     default:
2389         if (isIDFIRST_lazy_if(s,UTF))
2390             goto keylookup;
2391         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2392     case 4:
2393     case 26:
2394         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2395     case 0:
2396         if (!PL_rsfp) {
2397             PL_last_uni = 0;
2398             PL_last_lop = 0;
2399             if (PL_lex_brackets) {
2400                 if (PL_lex_formbrack)
2401                     yyerror("Format not terminated");
2402                 else
2403                     yyerror("Missing right curly or square bracket");
2404             }
2405             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2406                         "### Tokener got EOF\n");
2407             } );
2408             TOKEN(0);
2409         }
2410         if (s++ < PL_bufend)
2411             goto retry;                 /* ignore stray nulls */
2412         PL_last_uni = 0;
2413         PL_last_lop = 0;
2414         if (!PL_in_eval && !PL_preambled) {
2415             PL_preambled = TRUE;
2416             sv_setpv(PL_linestr,incl_perldb());
2417             if (SvCUR(PL_linestr))
2418                 sv_catpv(PL_linestr,";");
2419             if (PL_preambleav){
2420                 while(AvFILLp(PL_preambleav) >= 0) {
2421                     SV *tmpsv = av_shift(PL_preambleav);
2422                     sv_catsv(PL_linestr, tmpsv);
2423                     sv_catpv(PL_linestr, ";");
2424                     sv_free(tmpsv);
2425                 }
2426                 sv_free((SV*)PL_preambleav);
2427                 PL_preambleav = NULL;
2428             }
2429             if (PL_minus_n || PL_minus_p) {
2430                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2431                 if (PL_minus_l)
2432                     sv_catpv(PL_linestr,"chomp;");
2433                 if (PL_minus_a) {
2434                     if (PL_minus_F) {
2435                         if (strchr("/'\"", *PL_splitstr)
2436                               && strchr(PL_splitstr + 1, *PL_splitstr))
2437                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2438                         else {
2439                             char delim;
2440                             s = "'~#\200\1'"; /* surely one char is unused...*/
2441                             while (s[1] && strchr(PL_splitstr, *s))  s++;
2442                             delim = *s;
2443                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2444                                       "q" + (delim == '\''), delim);
2445                             for (s = PL_splitstr; *s; s++) {
2446                                 if (*s == '\\')
2447                                     sv_catpvn(PL_linestr, "\\", 1);
2448                                 sv_catpvn(PL_linestr, s, 1);
2449                             }
2450                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2451                         }
2452                     }
2453                     else
2454                         sv_catpv(PL_linestr,"our @F=split(' ');");
2455                 }
2456             }
2457             sv_catpv(PL_linestr, "\n");
2458             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2459             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2460             PL_last_lop = PL_last_uni = Nullch;
2461             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2462                 SV *sv = NEWSV(85,0);
2463
2464                 sv_upgrade(sv, SVt_PVMG);
2465                 sv_setsv(sv,PL_linestr);
2466                 (void)SvIOK_on(sv);
2467                 SvIVX(sv) = 0;
2468                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2469             }
2470             goto retry;
2471         }
2472         do {
2473             bof = PL_rsfp ? TRUE : FALSE;
2474             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2475               fake_eof:
2476                 if (PL_rsfp) {
2477                     if (PL_preprocess && !PL_in_eval)
2478                         (void)PerlProc_pclose(PL_rsfp);
2479                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2480                         PerlIO_clearerr(PL_rsfp);
2481                     else
2482                         (void)PerlIO_close(PL_rsfp);
2483                     PL_rsfp = Nullfp;
2484                     PL_doextract = FALSE;
2485                 }
2486                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2487                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2488                     sv_catpv(PL_linestr,";}");
2489                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2490                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2491                     PL_last_lop = PL_last_uni = Nullch;
2492                     PL_minus_n = PL_minus_p = 0;
2493                     goto retry;
2494                 }
2495                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2496                 PL_last_lop = PL_last_uni = Nullch;
2497                 sv_setpv(PL_linestr,"");
2498                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2499             }
2500             /* if it looks like the start of a BOM, check if it in fact is */
2501             else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2502 #ifdef PERLIO_IS_STDIO
2503 #  ifdef __GNU_LIBRARY__
2504 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2505 #      define FTELL_FOR_PIPE_IS_BROKEN
2506 #    endif
2507 #  else
2508 #    ifdef __GLIBC__
2509 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2510 #        define FTELL_FOR_PIPE_IS_BROKEN
2511 #      endif
2512 #    endif
2513 #  endif
2514 #endif
2515 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2516                 /* This loses the possibility to detect the bof
2517                  * situation on perl -P when the libc5 is being used.
2518                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2519                  */
2520                 if (!PL_preprocess)
2521                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2522 #else
2523                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2524 #endif
2525                 if (bof) {
2526                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2527                     s = swallow_bom((U8*)s);
2528                 }
2529             }
2530             if (PL_doextract) {
2531                 /* Incest with pod. */
2532                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2533                     sv_setpv(PL_linestr, "");
2534                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2535                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2536                     PL_last_lop = PL_last_uni = Nullch;
2537                     PL_doextract = FALSE;
2538                 }
2539             }
2540             incline(s);
2541         } while (PL_doextract);
2542         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2543         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2544             SV *sv = NEWSV(85,0);
2545
2546             sv_upgrade(sv, SVt_PVMG);
2547             sv_setsv(sv,PL_linestr);
2548             (void)SvIOK_on(sv);
2549             SvIVX(sv) = 0;
2550             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2551         }
2552         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2553         PL_last_lop = PL_last_uni = Nullch;
2554         if (CopLINE(PL_curcop) == 1) {
2555             while (s < PL_bufend && isSPACE(*s))
2556                 s++;
2557             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2558                 s++;
2559             d = Nullch;
2560             if (!PL_in_eval) {
2561                 if (*s == '#' && *(s+1) == '!')
2562                     d = s + 2;
2563 #ifdef ALTERNATE_SHEBANG
2564                 else {
2565                     static char as[] = ALTERNATE_SHEBANG;
2566                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2567                         d = s + (sizeof(as) - 1);
2568                 }
2569 #endif /* ALTERNATE_SHEBANG */
2570             }
2571             if (d) {
2572                 char *ipath;
2573                 char *ipathend;
2574
2575                 while (isSPACE(*d))
2576                     d++;
2577                 ipath = d;
2578                 while (*d && !isSPACE(*d))
2579                     d++;
2580                 ipathend = d;
2581
2582 #ifdef ARG_ZERO_IS_SCRIPT
2583                 if (ipathend > ipath) {
2584                     /*
2585                      * HP-UX (at least) sets argv[0] to the script name,
2586                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2587                      * at least, set argv[0] to the basename of the Perl
2588                      * interpreter. So, having found "#!", we'll set it right.
2589                      */
2590                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2591                     assert(SvPOK(x) || SvGMAGICAL(x));
2592                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2593                         sv_setpvn(x, ipath, ipathend - ipath);
2594                         SvSETMAGIC(x);
2595                     }
2596                     else {
2597                         STRLEN blen;
2598                         STRLEN llen;
2599                         char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2600                         char *lstart = SvPV(x,llen);
2601                         if (llen < blen) {
2602                             bstart += blen - llen;
2603                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2604                                 sv_setpvn(x, ipath, ipathend - ipath);
2605                                 SvSETMAGIC(x);
2606                             }
2607                         }
2608                     }
2609                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2610                 }
2611 #endif /* ARG_ZERO_IS_SCRIPT */
2612
2613                 /*
2614                  * Look for options.
2615                  */
2616                 d = instr(s,"perl -");
2617                 if (!d) {
2618                     d = instr(s,"perl");
2619 #if defined(DOSISH)
2620                     /* avoid getting into infinite loops when shebang
2621                      * line contains "Perl" rather than "perl" */
2622                     if (!d) {
2623                         for (d = ipathend-4; d >= ipath; --d) {
2624                             if ((*d == 'p' || *d == 'P')
2625                                 && !ibcmp(d, "perl", 4))
2626                             {
2627                                 break;
2628                             }
2629                         }
2630                         if (d < ipath)
2631                             d = Nullch;
2632                     }
2633 #endif
2634                 }
2635 #ifdef ALTERNATE_SHEBANG
2636                 /*
2637                  * If the ALTERNATE_SHEBANG on this system starts with a
2638                  * character that can be part of a Perl expression, then if
2639                  * we see it but not "perl", we're probably looking at the
2640                  * start of Perl code, not a request to hand off to some
2641                  * other interpreter.  Similarly, if "perl" is there, but
2642                  * not in the first 'word' of the line, we assume the line
2643                  * contains the start of the Perl program.
2644                  */
2645                 if (d && *s != '#') {
2646                     char *c = ipath;
2647                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2648                         c++;
2649                     if (c < d)
2650                         d = Nullch;     /* "perl" not in first word; ignore */
2651                     else
2652                         *s = '#';       /* Don't try to parse shebang line */
2653                 }
2654 #endif /* ALTERNATE_SHEBANG */
2655 #ifndef MACOS_TRADITIONAL
2656                 if (!d &&
2657                     *s == '#' &&
2658                     ipathend > ipath &&
2659                     !PL_minus_c &&
2660                     !instr(s,"indir") &&
2661                     instr(PL_origargv[0],"perl"))
2662                 {
2663                     char **newargv;
2664
2665                     *ipathend = '\0';
2666                     s = ipathend + 1;
2667                     while (s < PL_bufend && isSPACE(*s))
2668                         s++;
2669                     if (s < PL_bufend) {
2670                         Newz(899,newargv,PL_origargc+3,char*);
2671                         newargv[1] = s;
2672                         while (s < PL_bufend && !isSPACE(*s))
2673                             s++;
2674                         *s = '\0';
2675                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2676                     }
2677                     else
2678                         newargv = PL_origargv;
2679                     newargv[0] = ipath;
2680                     PERL_FPU_PRE_EXEC
2681                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2682                     PERL_FPU_POST_EXEC
2683                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2684                 }
2685 #endif
2686                 if (d) {
2687                     U32 oldpdb = PL_perldb;
2688                     bool oldn = PL_minus_n;
2689                     bool oldp = PL_minus_p;
2690
2691                     while (*d && !isSPACE(*d)) d++;
2692                     while (SPACE_OR_TAB(*d)) d++;
2693
2694                     if (*d++ == '-') {
2695                         bool switches_done = PL_doswitches;
2696                         do {
2697                             if (*d == 'M' || *d == 'm') {
2698                                 char *m = d;
2699                                 while (*d && !isSPACE(*d)) d++;
2700                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2701                                       (int)(d - m), m);
2702                             }
2703                             d = moreswitches(d);
2704                         } while (d);
2705                         if (PL_doswitches && !switches_done) {
2706                             int argc = PL_origargc;
2707                             char **argv = PL_origargv;
2708                             do {
2709                                 argc--,argv++;
2710                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2711                             init_argv_symbols(argc,argv);
2712                         }
2713                         if ((PERLDB_LINE && !oldpdb) ||
2714                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2715                               /* if we have already added "LINE: while (<>) {",
2716                                  we must not do it again */
2717                         {
2718                             sv_setpv(PL_linestr, "");
2719                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2720                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2721                             PL_last_lop = PL_last_uni = Nullch;
2722                             PL_preambled = FALSE;
2723                             if (PERLDB_LINE)
2724                                 (void)gv_fetchfile(PL_origfilename);
2725                             goto retry;
2726                         }
2727                         if (PL_doswitches && !switches_done) {
2728                             int argc = PL_origargc;
2729                             char **argv = PL_origargv;
2730                             do {
2731                                 argc--,argv++;
2732                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2733                             init_argv_symbols(argc,argv);
2734                         }
2735                     }
2736                 }
2737             }
2738         }
2739         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2740             PL_bufptr = s;
2741             PL_lex_state = LEX_FORMLINE;
2742             return yylex();
2743         }
2744         goto retry;
2745     case '\r':
2746 #ifdef PERL_STRICT_CR
2747         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2748         Perl_croak(aTHX_
2749       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2750 #endif
2751     case ' ': case '\t': case '\f': case 013:
2752 #ifdef MACOS_TRADITIONAL
2753     case '\312':
2754 #endif
2755         s++;
2756         goto retry;
2757     case '#':
2758     case '\n':
2759         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2760             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2761                 /* handle eval qq[#line 1 "foo"\n ...] */
2762                 CopLINE_dec(PL_curcop);
2763                 incline(s);
2764             }
2765             d = PL_bufend;
2766             while (s < d && *s != '\n')
2767                 s++;
2768             if (s < d)
2769                 s++;
2770             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2771               Perl_croak(aTHX_ "panic: input overflow");
2772             incline(s);
2773             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2774                 PL_bufptr = s;
2775                 PL_lex_state = LEX_FORMLINE;
2776                 return yylex();
2777             }
2778         }
2779         else {
2780             *s = '\0';
2781             PL_bufend = s;
2782         }
2783         goto retry;
2784     case '-':
2785         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2786             I32 ftst = 0;
2787
2788             s++;
2789             PL_bufptr = s;
2790             tmp = *s++;
2791
2792             while (s < PL_bufend && SPACE_OR_TAB(*s))
2793                 s++;
2794
2795             if (strnEQ(s,"=>",2)) {
2796                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2797                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2798                             "### Saw unary minus before =>, forcing word '%s'\n", s);
2799                 } );
2800                 OPERATOR('-');          /* unary minus */
2801             }
2802             PL_last_uni = PL_oldbufptr;
2803             switch (tmp) {
2804             case 'r': ftst = OP_FTEREAD;        break;
2805             case 'w': ftst = OP_FTEWRITE;       break;
2806             case 'x': ftst = OP_FTEEXEC;        break;
2807             case 'o': ftst = OP_FTEOWNED;       break;
2808             case 'R': ftst = OP_FTRREAD;        break;
2809             case 'W': ftst = OP_FTRWRITE;       break;
2810             case 'X': ftst = OP_FTREXEC;        break;
2811             case 'O': ftst = OP_FTROWNED;       break;
2812             case 'e': ftst = OP_FTIS;           break;
2813             case 'z': ftst = OP_FTZERO;         break;
2814             case 's': ftst = OP_FTSIZE;         break;
2815             case 'f': ftst = OP_FTFILE;         break;
2816             case 'd': ftst = OP_FTDIR;          break;
2817             case 'l': ftst = OP_FTLINK;         break;
2818             case 'p': ftst = OP_FTPIPE;         break;
2819             case 'S': ftst = OP_FTSOCK;         break;
2820             case 'u': ftst = OP_FTSUID;         break;
2821             case 'g': ftst = OP_FTSGID;         break;
2822             case 'k': ftst = OP_FTSVTX;         break;
2823             case 'b': ftst = OP_FTBLK;          break;
2824             case 'c': ftst = OP_FTCHR;          break;
2825             case 't': ftst = OP_FTTTY;          break;
2826             case 'T': ftst = OP_FTTEXT;         break;
2827             case 'B': ftst = OP_FTBINARY;       break;
2828             case 'M': case 'A': case 'C':
2829                 gv_fetchpv("\024",TRUE, SVt_PV);
2830                 switch (tmp) {
2831                 case 'M': ftst = OP_FTMTIME;    break;
2832                 case 'A': ftst = OP_FTATIME;    break;
2833                 case 'C': ftst = OP_FTCTIME;    break;
2834                 default:                        break;
2835                 }
2836                 break;
2837             default:
2838                 break;
2839             }
2840             if (ftst) {
2841                 PL_last_lop_op = (OPCODE)ftst;
2842                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2843                         "### Saw file test %c\n", (int)ftst);
2844                 } );
2845                 FTST(ftst);
2846             }
2847             else {
2848                 /* Assume it was a minus followed by a one-letter named
2849                  * subroutine call (or a -bareword), then. */
2850                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2851                         "### '-%c' looked like a file test but was not\n",
2852                         tmp);
2853                 } );
2854                 s = --PL_bufptr;
2855             }
2856         }
2857         tmp = *s++;
2858         if (*s == tmp) {
2859             s++;
2860             if (PL_expect == XOPERATOR)
2861                 TERM(POSTDEC);
2862             else
2863                 OPERATOR(PREDEC);
2864         }
2865         else if (*s == '>') {
2866             s++;
2867             s = skipspace(s);
2868             if (isIDFIRST_lazy_if(s,UTF)) {
2869                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2870                 TOKEN(ARROW);
2871             }
2872             else if (*s == '$')
2873                 OPERATOR(ARROW);
2874             else
2875                 TERM(ARROW);
2876         }
2877         if (PL_expect == XOPERATOR)
2878             Aop(OP_SUBTRACT);
2879         else {
2880             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2881                 check_uni();
2882             OPERATOR('-');              /* unary minus */
2883         }
2884
2885     case '+':
2886         tmp = *s++;
2887         if (*s == tmp) {
2888             s++;
2889             if (PL_expect == XOPERATOR)
2890                 TERM(POSTINC);
2891             else
2892                 OPERATOR(PREINC);
2893         }
2894         if (PL_expect == XOPERATOR)
2895             Aop(OP_ADD);
2896         else {
2897             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2898                 check_uni();
2899             OPERATOR('+');
2900         }
2901
2902     case '*':
2903         if (PL_expect != XOPERATOR) {
2904             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2905             PL_expect = XOPERATOR;
2906             force_ident(PL_tokenbuf, '*');
2907             if (!*PL_tokenbuf)
2908                 PREREF('*');
2909             TERM('*');
2910         }
2911         s++;
2912         if (*s == '*') {
2913             s++;
2914             PWop(OP_POW);
2915         }
2916         Mop(OP_MULTIPLY);
2917
2918     case '%':
2919         if (PL_expect == XOPERATOR) {
2920             ++s;
2921             Mop(OP_MODULO);
2922         }
2923         PL_tokenbuf[0] = '%';
2924         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2925         if (!PL_tokenbuf[1]) {
2926             PREREF('%');
2927         }
2928         PL_pending_ident = '%';
2929         TERM('%');
2930
2931     case '^':
2932         s++;
2933         BOop(OP_BIT_XOR);
2934     case '[':
2935         PL_lex_brackets++;
2936         /* FALL THROUGH */
2937     case '~':
2938     case ',':
2939         tmp = *s++;
2940         OPERATOR(tmp);
2941     case ':':
2942         if (s[1] == ':') {
2943             len = 0;
2944             goto just_a_word;
2945         }
2946         s++;
2947         switch (PL_expect) {
2948             OP *attrs;
2949         case XOPERATOR:
2950             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2951                 break;
2952             PL_bufptr = s;      /* update in case we back off */
2953             goto grabattrs;
2954         case XATTRBLOCK:
2955             PL_expect = XBLOCK;
2956             goto grabattrs;
2957         case XATTRTERM:
2958             PL_expect = XTERMBLOCK;
2959          grabattrs:
2960             s = skipspace(s);
2961             attrs = Nullop;
2962             while (isIDFIRST_lazy_if(s,UTF)) {
2963                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2964                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2965                     if (tmp < 0) tmp = -tmp;
2966                     switch (tmp) {
2967                     case KEY_or:
2968                     case KEY_and:
2969                     case KEY_err:
2970                     case KEY_for:
2971                     case KEY_unless:
2972                     case KEY_if:
2973                     case KEY_while:
2974                     case KEY_until:
2975                         goto got_attrs;
2976                     default:
2977                         break;
2978                     }
2979                 }
2980                 if (*d == '(') {
2981                     d = scan_str(d,TRUE,TRUE);
2982                     if (!d) {
2983                         /* MUST advance bufptr here to avoid bogus
2984                            "at end of line" context messages from yyerror().
2985                          */
2986                         PL_bufptr = s + len;
2987                         yyerror("Unterminated attribute parameter in attribute list");
2988                         if (attrs)
2989                             op_free(attrs);
2990                         return 0;       /* EOF indicator */
2991                     }
2992                 }
2993                 if (PL_lex_stuff) {
2994                     SV *sv = newSVpvn(s, len);
2995                     sv_catsv(sv, PL_lex_stuff);
2996                     attrs = append_elem(OP_LIST, attrs,
2997                                         newSVOP(OP_CONST, 0, sv));
2998                     SvREFCNT_dec(PL_lex_stuff);
2999                     PL_lex_stuff = Nullsv;
3000                 }
3001                 else {
3002                     if (len == 6 && strnEQ(s, "unique", len)) {
3003                         if (PL_in_my == KEY_our)
3004 #ifdef USE_ITHREADS
3005                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3006 #else
3007                             ; /* skip to avoid loading attributes.pm */
3008 #endif
3009                         else 
3010                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3011                     }
3012
3013                     /* NOTE: any CV attrs applied here need to be part of
3014                        the CVf_BUILTIN_ATTRS define in cv.h! */
3015                     else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3016                         CvLVALUE_on(PL_compcv);
3017                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3018                         CvLOCKED_on(PL_compcv);
3019                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3020                         CvMETHOD_on(PL_compcv);
3021                     else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3022                         CvASSERTION_on(PL_compcv);
3023                     /* After we've set the flags, it could be argued that
3024                        we don't need to do the attributes.pm-based setting
3025                        process, and shouldn't bother appending recognized
3026                        flags.  To experiment with that, uncomment the
3027                        following "else".  (Note that's already been
3028                        uncommented.  That keeps the above-applied built-in
3029                        attributes from being intercepted (and possibly
3030                        rejected) by a package's attribute routines, but is
3031                        justified by the performance win for the common case
3032                        of applying only built-in attributes.) */
3033                     else
3034                         attrs = append_elem(OP_LIST, attrs,
3035                                             newSVOP(OP_CONST, 0,
3036                                                     newSVpvn(s, len)));
3037                 }
3038                 s = skipspace(d);
3039                 if (*s == ':' && s[1] != ':')
3040                     s = skipspace(s+1);
3041                 else if (s == d)
3042                     break;      /* require real whitespace or :'s */
3043             }
3044             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3045             if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3046                 char q = ((*s == '\'') ? '"' : '\'');
3047                 /* If here for an expression, and parsed no attrs, back off. */
3048                 if (tmp == '=' && !attrs) {
3049                     s = PL_bufptr;
3050                     break;
3051                 }
3052                 /* MUST advance bufptr here to avoid bogus "at end of line"
3053                    context messages from yyerror().
3054                  */
3055                 PL_bufptr = s;
3056                 if (!*s)
3057                     yyerror("Unterminated attribute list");
3058                 else
3059                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3060                                       q, *s, q));
3061                 if (attrs)
3062                     op_free(attrs);
3063                 OPERATOR(':');
3064             }
3065         got_attrs:
3066             if (attrs) {
3067                 PL_nextval[PL_nexttoke].opval = attrs;
3068                 force_next(THING);
3069             }
3070             TOKEN(COLONATTR);
3071         }
3072         OPERATOR(':');
3073     case '(':
3074         s++;
3075         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3076             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3077         else
3078             PL_expect = XTERM;
3079         s = skipspace(s);
3080         TOKEN('(');
3081     case ';':
3082         CLINE;
3083         tmp = *s++;
3084         OPERATOR(tmp);
3085     case ')':
3086         tmp = *s++;
3087         s = skipspace(s);
3088         if (*s == '{')
3089             PREBLOCK(tmp);
3090         TERM(tmp);
3091     case ']':
3092         s++;
3093         if (PL_lex_brackets <= 0)
3094             yyerror("Unmatched right square bracket");
3095         else
3096             --PL_lex_brackets;
3097         if (PL_lex_state == LEX_INTERPNORMAL) {
3098             if (PL_lex_brackets == 0) {
3099                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3100                     PL_lex_state = LEX_INTERPEND;
3101             }
3102         }
3103         TERM(']');
3104     case '{':
3105       leftbracket:
3106         s++;
3107         if (PL_lex_brackets > 100) {
3108             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3109         }
3110         switch (PL_expect) {
3111         case XTERM:
3112             if (PL_lex_formbrack) {
3113                 s--;
3114                 PRETERMBLOCK(DO);
3115             }
3116             if (PL_oldoldbufptr == PL_last_lop)
3117                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3118             else
3119                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3120             OPERATOR(HASHBRACK);
3121         case XOPERATOR:
3122             while (s < PL_bufend && SPACE_OR_TAB(*s))
3123                 s++;
3124             d = s;
3125             PL_tokenbuf[0] = '\0';
3126             if (d < PL_bufend && *d == '-') {
3127                 PL_tokenbuf[0] = '-';
3128                 d++;
3129                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3130                     d++;
3131             }
3132             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3133                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3134                               FALSE, &len);
3135                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3136                     d++;
3137                 if (*d == '}') {
3138                     char minus = (PL_tokenbuf[0] == '-');
3139                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3140                     if (minus)
3141                         force_next('-');
3142                 }
3143             }
3144             /* FALL THROUGH */
3145         case XATTRBLOCK:
3146         case XBLOCK:
3147             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3148             PL_expect = XSTATE;
3149             break;
3150         case XATTRTERM:
3151         case XTERMBLOCK:
3152             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3153             PL_expect = XSTATE;
3154             break;
3155         default: {
3156                 char *t;
3157                 if (PL_oldoldbufptr == PL_last_lop)
3158                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3159                 else
3160                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3161                 s = skipspace(s);
3162                 if (*s == '}') {
3163                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3164                         PL_expect = XTERM;
3165                         /* This hack is to get the ${} in the message. */
3166                         PL_bufptr = s+1;
3167                         yyerror("syntax error");
3168                         break;
3169                     }
3170                     OPERATOR(HASHBRACK);
3171                 }
3172                 /* This hack serves to disambiguate a pair of curlies
3173                  * as being a block or an anon hash.  Normally, expectation
3174                  * determines that, but in cases where we're not in a
3175                  * position to expect anything in particular (like inside
3176                  * eval"") we have to resolve the ambiguity.  This code
3177                  * covers the case where the first term in the curlies is a
3178                  * quoted string.  Most other cases need to be explicitly
3179                  * disambiguated by prepending a `+' before the opening
3180                  * curly in order to force resolution as an anon hash.
3181                  *
3182                  * XXX should probably propagate the outer expectation
3183                  * into eval"" to rely less on this hack, but that could
3184                  * potentially break current behavior of eval"".
3185                  * GSAR 97-07-21
3186                  */
3187                 t = s;
3188                 if (*s == '\'' || *s == '"' || *s == '`') {
3189                     /* common case: get past first string, handling escapes */
3190                     for (t++; t < PL_bufend && *t != *s;)
3191                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3192                             t++;
3193                     t++;
3194                 }
3195                 else if (*s == 'q') {
3196                     if (++t < PL_bufend
3197                         && (!isALNUM(*t)
3198                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3199                                 && !isALNUM(*t))))
3200                     {
3201                         /* skip q//-like construct */
3202                         char *tmps;
3203                         char open, close, term;
3204                         I32 brackets = 1;
3205
3206                         while (t < PL_bufend && isSPACE(*t))
3207                             t++;
3208                         /* check for q => */
3209                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3210                             OPERATOR(HASHBRACK);
3211                         }
3212                         term = *t;
3213                         open = term;
3214                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3215                             term = tmps[5];
3216                         close = term;
3217                         if (open == close)
3218                             for (t++; t < PL_bufend; t++) {
3219                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3220                                     t++;
3221                                 else if (*t == open)
3222                                     break;
3223                             }
3224                         else {
3225                             for (t++; t < PL_bufend; t++) {
3226                                 if (*t == '\\' && t+1 < PL_bufend)
3227                                     t++;
3228                                 else if (*t == close && --brackets <= 0)
3229                                     break;
3230                                 else if (*t == open)
3231                                     brackets++;
3232                             }
3233                         }
3234                         t++;
3235                     }
3236                     else
3237                         /* skip plain q word */
3238                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3239                              t += UTF8SKIP(t);
3240                 }
3241                 else if (isALNUM_lazy_if(t,UTF)) {
3242                     t += UTF8SKIP(t);
3243                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3244                          t += UTF8SKIP(t);
3245                 }
3246                 while (t < PL_bufend && isSPACE(*t))
3247                     t++;
3248                 /* if comma follows first term, call it an anon hash */
3249                 /* XXX it could be a comma expression with loop modifiers */
3250                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3251                                    || (*t == '=' && t[1] == '>')))
3252                     OPERATOR(HASHBRACK);
3253                 if (PL_expect == XREF)
3254                     PL_expect = XTERM;
3255                 else {
3256                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3257                     PL_expect = XSTATE;
3258                 }
3259             }
3260             break;
3261         }
3262         yylval.ival = CopLINE(PL_curcop);
3263         if (isSPACE(*s) || *s == '#')
3264             PL_copline = NOLINE;   /* invalidate current command line number */
3265         TOKEN('{');
3266     case '}':
3267       rightbracket:
3268         s++;
3269         if (PL_lex_brackets <= 0)
3270             yyerror("Unmatched right curly bracket");
3271         else
3272             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3273         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3274             PL_lex_formbrack = 0;
3275         if (PL_lex_state == LEX_INTERPNORMAL) {
3276             if (PL_lex_brackets == 0) {
3277                 if (PL_expect & XFAKEBRACK) {
3278                     PL_expect &= XENUMMASK;
3279                     PL_lex_state = LEX_INTERPEND;
3280                     PL_bufptr = s;
3281                     return yylex();     /* ignore fake brackets */
3282                 }
3283                 if (*s == '-' && s[1] == '>')
3284                     PL_lex_state = LEX_INTERPENDMAYBE;
3285                 else if (*s != '[' && *s != '{')
3286                     PL_lex_state = LEX_INTERPEND;
3287             }
3288         }
3289         if (PL_expect & XFAKEBRACK) {
3290             PL_expect &= XENUMMASK;
3291             PL_bufptr = s;
3292             return yylex();             /* ignore fake brackets */
3293         }
3294         force_next('}');
3295         TOKEN(';');
3296     case '&':
3297         s++;
3298         tmp = *s++;
3299         if (tmp == '&')
3300             AOPERATOR(ANDAND);
3301         s--;
3302         if (PL_expect == XOPERATOR) {
3303             if (ckWARN(WARN_SEMICOLON)
3304                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3305             {
3306                 CopLINE_dec(PL_curcop);
3307                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3308                 CopLINE_inc(PL_curcop);
3309             }
3310             BAop(OP_BIT_AND);
3311         }
3312
3313         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3314         if (*PL_tokenbuf) {
3315             PL_expect = XOPERATOR;
3316             force_ident(PL_tokenbuf, '&');
3317         }
3318         else
3319             PREREF('&');
3320         yylval.ival = (OPpENTERSUB_AMPER<<8);
3321         TERM('&');
3322
3323     case '|':
3324         s++;
3325         tmp = *s++;
3326         if (tmp == '|')
3327             AOPERATOR(OROR);
3328         s--;
3329         BOop(OP_BIT_OR);
3330     case '=':
3331         s++;
3332         tmp = *s++;
3333         if (tmp == '=')
3334             Eop(OP_EQ);
3335         if (tmp == '>')
3336             OPERATOR(',');
3337         if (tmp == '~')
3338             PMop(OP_MATCH);
3339         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3340             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3341         s--;
3342         if (PL_expect == XSTATE && isALPHA(tmp) &&
3343                 (s == PL_linestart+1 || s[-2] == '\n') )
3344         {
3345             if (PL_in_eval && !PL_rsfp) {
3346                 d = PL_bufend;
3347                 while (s < d) {
3348                     if (*s++ == '\n') {
3349                         incline(s);
3350                         if (strnEQ(s,"=cut",4)) {
3351                             s = strchr(s,'\n');
3352                             if (s)
3353                                 s++;
3354                             else
3355                                 s = d;
3356                             incline(s);
3357                             goto retry;
3358                         }
3359                     }
3360                 }
3361                 goto retry;
3362             }
3363             s = PL_bufend;
3364             PL_doextract = TRUE;
3365             goto retry;
3366         }
3367         if (PL_lex_brackets < PL_lex_formbrack) {
3368             char *t;
3369 #ifdef PERL_STRICT_CR
3370             for (t = s; SPACE_OR_TAB(*t); t++) ;
3371 #else
3372             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3373 #endif
3374             if (*t == '\n' || *t == '#') {
3375                 s--;
3376                 PL_expect = XBLOCK;
3377                 goto leftbracket;
3378             }
3379         }
3380         yylval.ival = 0;
3381         OPERATOR(ASSIGNOP);
3382     case '!':
3383         s++;
3384         tmp = *s++;
3385         if (tmp == '=') {
3386             /* was this !=~ where !~ was meant?
3387              * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3388
3389             if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3390                 char *t = s+1;
3391
3392                 while (t < PL_bufend && isSPACE(*t))
3393                     ++t;
3394
3395                 if (*t == '/' || *t == '?' ||
3396                     ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
3397                     (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3398                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3399                                 "!=~ should be !~");
3400             }
3401             Eop(OP_NE);
3402         }
3403         if (tmp == '~')
3404             PMop(OP_NOT);
3405         s--;
3406         OPERATOR('!');
3407     case '<':
3408         if (PL_expect != XOPERATOR) {
3409             if (s[1] != '<' && !strchr(s,'>'))
3410                 check_uni();
3411             if (s[1] == '<')
3412                 s = scan_heredoc(s);
3413             else
3414                 s = scan_inputsymbol(s);
3415             TERM(sublex_start());
3416         }
3417         s++;
3418         tmp = *s++;
3419         if (tmp == '<')
3420             SHop(OP_LEFT_SHIFT);
3421         if (tmp == '=') {
3422             tmp = *s++;
3423             if (tmp == '>')
3424                 Eop(OP_NCMP);
3425             s--;
3426             Rop(OP_LE);
3427         }
3428         s--;
3429         Rop(OP_LT);
3430     case '>':
3431         s++;
3432         tmp = *s++;
3433         if (tmp == '>')
3434             SHop(OP_RIGHT_SHIFT);
3435         if (tmp == '=')
3436             Rop(OP_GE);
3437         s--;
3438         Rop(OP_GT);
3439
3440     case '$':
3441         CLINE;
3442
3443         if (PL_expect == XOPERATOR) {
3444             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3445                 PL_expect = XTERM;
3446                 depcom();
3447                 return ','; /* grandfather non-comma-format format */
3448             }
3449         }
3450
3451         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3452             PL_tokenbuf[0] = '@';
3453             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3454                            sizeof PL_tokenbuf - 1, FALSE);
3455             if (PL_expect == XOPERATOR)
3456                 no_op("Array length", s);
3457             if (!PL_tokenbuf[1])
3458                 PREREF(DOLSHARP);
3459             PL_expect = XOPERATOR;
3460             PL_pending_ident = '#';
3461             TOKEN(DOLSHARP);
3462         }
3463
3464         PL_tokenbuf[0] = '$';
3465         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3466                        sizeof PL_tokenbuf - 1, FALSE);
3467         if (PL_expect == XOPERATOR)
3468             no_op("Scalar", s);
3469         if (!PL_tokenbuf[1]) {
3470             if (s == PL_bufend)
3471                 yyerror("Final $ should be \\$ or $name");
3472             PREREF('$');
3473         }
3474
3475         /* This kludge not intended to be bulletproof. */
3476         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3477             yylval.opval = newSVOP(OP_CONST, 0,
3478                                    newSViv(PL_compiling.cop_arybase));
3479             yylval.opval->op_private = OPpCONST_ARYBASE;
3480             TERM(THING);
3481         }
3482
3483         d = s;
3484         tmp = (I32)*s;
3485         if (PL_lex_state == LEX_NORMAL)
3486             s = skipspace(s);
3487
3488         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3489             char *t;
3490             if (*s == '[') {
3491                 PL_tokenbuf[0] = '@';
3492                 if (ckWARN(WARN_SYNTAX)) {
3493                     for(t = s + 1;
3494                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3495                         t++) ;
3496                     if (*t++ == ',') {
3497                         PL_bufptr = skipspace(PL_bufptr);
3498                         while (t < PL_bufend && *t != ']')
3499                             t++;
3500                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3501                                 "Multidimensional syntax %.*s not supported",
3502                                 (t - PL_bufptr) + 1, PL_bufptr);
3503                     }
3504                 }
3505             }
3506             else if (*s == '{') {
3507                 PL_tokenbuf[0] = '%';
3508                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3509                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3510                 {
3511                     char tmpbuf[sizeof PL_tokenbuf];
3512                     STRLEN len;
3513                     for (t++; isSPACE(*t); t++) ;
3514                     if (isIDFIRST_lazy_if(t,UTF)) {
3515                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3516                         for (; isSPACE(*t); t++) ;
3517                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3518                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3519                                 "You need to quote \"%s\"", tmpbuf);
3520                     }
3521                 }
3522             }
3523         }
3524
3525         PL_expect = XOPERATOR;
3526         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3527             bool islop = (PL_last_lop == PL_oldoldbufptr);
3528             if (!islop || PL_last_lop_op == OP_GREPSTART)
3529                 PL_expect = XOPERATOR;
3530             else if (strchr("$@\"'`q", *s))
3531                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3532             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3533                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3534             else if (isIDFIRST_lazy_if(s,UTF)) {
3535                 char tmpbuf[sizeof PL_tokenbuf];
3536                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3537                 if ((tmp = keyword(tmpbuf, len))) {
3538                     /* binary operators exclude handle interpretations */
3539                     switch (tmp) {
3540                     case -KEY_x:
3541                     case -KEY_eq:
3542                     case -KEY_ne:
3543                     case -KEY_gt:
3544                     case -KEY_lt:
3545                     case -KEY_ge:
3546                     case -KEY_le:
3547                     case -KEY_cmp:
3548                         break;
3549                     default:
3550                         PL_expect = XTERM;      /* e.g. print $fh length() */
3551                         break;
3552                     }
3553                 }
3554                 else {
3555                     PL_expect = XTERM;          /* e.g. print $fh subr() */
3556                 }
3557             }
3558             else if (isDIGIT(*s))
3559                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3560             else if (*s == '.' && isDIGIT(s[1]))
3561                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3562             else if (strchr("?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3563                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3564             else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3565                 PL_expect = XTERM;              /* e.g. print $fh /.../
3566                                                  XXX except DORDOR operator */
3567             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3568                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3569         }
3570         PL_pending_ident = '$';
3571         TOKEN('$');
3572
3573     case '@':
3574         if (PL_expect == XOPERATOR)
3575             no_op("Array", s);
3576         PL_tokenbuf[0] = '@';
3577         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3578         if (!PL_tokenbuf[1]) {
3579             PREREF('@');
3580         }
3581         if (PL_lex_state == LEX_NORMAL)
3582             s = skipspace(s);
3583         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3584             if (*s == '{')
3585                 PL_tokenbuf[0] = '%';
3586
3587             /* Warn about @ where they meant $. */
3588             if (ckWARN(WARN_SYNTAX)) {
3589                 if (*s == '[' || *s == '{') {
3590                     char *t = s + 1;
3591                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3592                         t++;
3593                     if (*t == '}' || *t == ']') {
3594                         t++;
3595                         PL_bufptr = skipspace(PL_bufptr);
3596                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3597                             "Scalar value %.*s better written as $%.*s",
3598                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3599                     }
3600                 }
3601             }
3602         }
3603         PL_pending_ident = '@';
3604         TERM('@');
3605
3606      case '/':                  /* may be division, defined-or, or pattern */
3607         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3608             s += 2;
3609             AOPERATOR(DORDOR);
3610         }
3611      case '?':                  /* may either be conditional or pattern */
3612          if(PL_expect == XOPERATOR) {
3613              tmp = *s++;
3614              if(tmp == '?') {
3615                   OPERATOR('?');
3616              }
3617              else {
3618                  tmp = *s++;
3619                  if(tmp == '/') {
3620                      /* A // operator. */
3621                     AOPERATOR(DORDOR);
3622                  }
3623                  else {
3624                      s--;
3625                      Mop(OP_DIVIDE);
3626                  }
3627              }
3628          }
3629          else {
3630              /* Disable warning on "study /blah/" */
3631              if (PL_oldoldbufptr == PL_last_uni
3632               && (*PL_last_uni != 's' || s - PL_last_uni < 5
3633                   || memNE(PL_last_uni, "study", 5)
3634                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
3635               ))
3636                  check_uni();
3637              s = scan_pat(s,OP_MATCH);
3638              TERM(sublex_start());
3639          }
3640
3641     case '.':
3642         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3643 #ifdef PERL_STRICT_CR
3644             && s[1] == '\n'
3645 #else
3646             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3647 #endif
3648             && (s == PL_linestart || s[-1] == '\n') )
3649         {
3650             PL_lex_formbrack = 0;
3651             PL_expect = XSTATE;
3652             goto rightbracket;
3653         }
3654         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3655             tmp = *s++;
3656             if (*s == tmp) {
3657                 s++;
3658                 if (*s == tmp) {
3659                     s++;
3660                     yylval.ival = OPf_SPECIAL;
3661                 }
3662                 else
3663                     yylval.ival = 0;
3664                 OPERATOR(DOTDOT);
3665             }
3666             if (PL_expect != XOPERATOR)
3667                 check_uni();
3668             Aop(OP_CONCAT);
3669         }
3670         /* FALL THROUGH */
3671     case '0': case '1': case '2': case '3': case '4':
3672     case '5': case '6': case '7': case '8': case '9':
3673         s = scan_num(s, &yylval);
3674         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3675                     "### Saw number in '%s'\n", s);
3676         } );
3677         if (PL_expect == XOPERATOR)
3678             no_op("Number",s);
3679         TERM(THING);
3680
3681     case '\'':
3682         s = scan_str(s,FALSE,FALSE);
3683         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3684                     "### Saw string before '%s'\n", s);
3685         } );
3686         if (PL_expect == XOPERATOR) {
3687             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3688                 PL_expect = XTERM;
3689                 depcom();
3690                 return ',';     /* grandfather non-comma-format format */
3691             }
3692             else
3693                 no_op("String",s);
3694         }
3695         if (!s)
3696             missingterm((char*)0);
3697         yylval.ival = OP_CONST;
3698         TERM(sublex_start());
3699
3700     case '"':
3701         s = scan_str(s,FALSE,FALSE);
3702         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3703                     "### Saw string before '%s'\n", s);
3704         } );
3705         if (PL_expect == XOPERATOR) {
3706             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3707                 PL_expect = XTERM;
3708                 depcom();
3709                 return ',';     /* grandfather non-comma-format format */
3710             }
3711             else
3712                 no_op("String",s);
3713         }
3714         if (!s)
3715             missingterm((char*)0);
3716         yylval.ival = OP_CONST;
3717         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3718             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3719                 yylval.ival = OP_STRINGIFY;
3720                 break;
3721             }
3722         }
3723         TERM(sublex_start());
3724
3725     case '`':
3726         s = scan_str(s,FALSE,FALSE);
3727         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3728                     "### Saw backtick string before '%s'\n", s);
3729         } );
3730         if (PL_expect == XOPERATOR)
3731             no_op("Backticks",s);
3732         if (!s)
3733             missingterm((char*)0);
3734         yylval.ival = OP_BACKTICK;
3735         set_csh();
3736         TERM(sublex_start());
3737
3738     case '\\':
3739         s++;
3740         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3741             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3742                         *s, *s);
3743         if (PL_expect == XOPERATOR)
3744             no_op("Backslash",s);
3745         OPERATOR(REFGEN);
3746
3747     case 'v':
3748         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3749             char *start = s;
3750             start++;
3751             start++;
3752             while (isDIGIT(*start) || *start == '_')
3753                 start++;
3754             if (*start == '.' && isDIGIT(start[1])) {
3755                 s = scan_num(s, &yylval);
3756                 TERM(THING);
3757             }
3758             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3759             else if (!isALPHA(*start) && (PL_expect == XTERM
3760                         || PL_expect == XREF || PL_expect == XSTATE
3761                         || PL_expect == XTERMORDORDOR)) {
3762                 char c = *start;
3763                 GV *gv;
3764                 *start = '\0';
3765                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3766                 *start = c;
3767                 if (!gv) {
3768                     s = scan_num(s, &yylval);
3769                     TERM(THING);
3770                 }
3771             }
3772         }
3773         goto keylookup;
3774     case 'x':
3775         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3776             s++;
3777             Mop(OP_REPEAT);
3778         }
3779         goto keylookup;
3780
3781     case '_':
3782     case 'a': case 'A':
3783     case 'b': case 'B':
3784     case 'c': case 'C':
3785     case 'd': case 'D':
3786     case 'e': case 'E':
3787     case 'f': case 'F':
3788     case 'g': case 'G':
3789     case 'h': case 'H':
3790     case 'i': case 'I':
3791     case 'j': case 'J':
3792     case 'k': case 'K':
3793     case 'l': case 'L':
3794     case 'm': case 'M':
3795     case 'n': case 'N':
3796     case 'o': case 'O':
3797     case 'p': case 'P':
3798     case 'q': case 'Q':
3799     case 'r': case 'R':
3800     case 's': case 'S':
3801     case 't': case 'T':
3802     case 'u': case 'U':
3803               case 'V':
3804     case 'w': case 'W':
3805               case 'X':
3806     case 'y': case 'Y':
3807     case 'z': case 'Z':
3808
3809       keylookup: {
3810         orig_keyword = 0;
3811         gv = Nullgv;
3812         gvp = 0;
3813
3814         PL_bufptr = s;
3815         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3816
3817         /* Some keywords can be followed by any delimiter, including ':' */
3818         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3819                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3820                              (PL_tokenbuf[0] == 'q' &&
3821                               strchr("qwxr", PL_tokenbuf[1])))));
3822
3823         /* x::* is just a word, unless x is "CORE" */
3824         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3825             goto just_a_word;
3826
3827         d = s;
3828         while (d < PL_bufend && isSPACE(*d))
3829                 d++;    /* no comments skipped here, or s### is misparsed */
3830
3831         /* Is this a label? */
3832         if (!tmp && PL_expect == XSTATE
3833               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3834             s = d + 1;
3835             yylval.pval = savepv(PL_tokenbuf);
3836             CLINE;
3837             TOKEN(LABEL);
3838         }
3839
3840         /* Check for keywords */
3841         tmp = keyword(PL_tokenbuf, len);
3842
3843         /* Is this a word before a => operator? */
3844         if (*d == '=' && d[1] == '>') {
3845             CLINE;
3846             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3847             yylval.opval->op_private = OPpCONST_BARE;
3848             if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3849               SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3850             TERM(WORD);
3851         }
3852
3853         if (tmp < 0) {                  /* second-class keyword? */
3854             GV *ogv = Nullgv;   /* override (winner) */
3855             GV *hgv = Nullgv;   /* hidden (loser) */
3856             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3857                 CV *cv;
3858                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3859                     (cv = GvCVu(gv)))
3860                 {
3861                     if (GvIMPORTED_CV(gv))
3862                         ogv = gv;
3863                     else if (! CvMETHOD(cv))
3864                         hgv = gv;
3865                 }
3866                 if (!ogv &&
3867                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3868                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3869                     GvCVu(gv) && GvIMPORTED_CV(gv))
3870                 {
3871                     ogv = gv;
3872                 }
3873             }
3874             if (ogv) {
3875                 orig_keyword = tmp;
3876                 tmp = 0;                /* overridden by import or by GLOBAL */
3877             }
3878             else if (gv && !gvp
3879                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3880                      && GvCVu(gv)
3881                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3882             {
3883                 tmp = 0;                /* any sub overrides "weak" keyword */
3884             }
3885             else {                      /* no override */
3886                 tmp = -tmp;
3887                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
3888                     Perl_warner(aTHX_ packWARN(WARN_MISC),
3889                             "dump() better written as CORE::dump()");
3890                 }
3891                 gv = Nullgv;
3892                 gvp = 0;
3893                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3894                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3895                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3896                         "Ambiguous call resolved as CORE::%s(), %s",
3897                          GvENAME(hgv), "qualify as such or use &");
3898             }
3899         }
3900
3901       reserved_word:
3902         switch (tmp) {
3903
3904         default:                        /* not a keyword */
3905           just_a_word: {
3906                 SV *sv;
3907                 int pkgname = 0;
3908                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3909
3910                 /* Get the rest if it looks like a package qualifier */
3911
3912                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3913                     STRLEN morelen;
3914                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3915                                   TRUE, &morelen);
3916                     if (!morelen)
3917                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3918                                 *s == '\'' ? "'" : "::");
3919                     len += morelen;
3920                     pkgname = 1;
3921                 }
3922
3923                 if (PL_expect == XOPERATOR) {
3924                     if (PL_bufptr == PL_linestart) {
3925                         CopLINE_dec(PL_curcop);
3926                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3927                         CopLINE_inc(PL_curcop);
3928                     }
3929                     else
3930                         no_op("Bareword",s);
3931                 }
3932
3933                 /* Look for a subroutine with this name in current package,
3934                    unless name is "Foo::", in which case Foo is a bearword
3935                    (and a package name). */
3936
3937                 if (len > 2 &&
3938                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3939                 {
3940                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3941                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
3942                             "Bareword \"%s\" refers to nonexistent package",
3943                              PL_tokenbuf);
3944                     len -= 2;
3945                     PL_tokenbuf[len] = '\0';
3946                     gv = Nullgv;
3947                     gvp = 0;
3948                 }
3949                 else {
3950                     len = 0;
3951                     if (!gv)
3952                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3953                 }
3954
3955                 /* if we saw a global override before, get the right name */
3956
3957                 if (gvp) {
3958                     sv = newSVpvn("CORE::GLOBAL::",14);
3959                     sv_catpv(sv,PL_tokenbuf);
3960                 }
3961                 else
3962                     sv = newSVpv(PL_tokenbuf,0);
3963
3964                 /* Presume this is going to be a bareword of some sort. */
3965
3966                 CLINE;
3967                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3968                 yylval.opval->op_private = OPpCONST_BARE;
3969                 /* UTF-8 package name? */
3970                 if (UTF && !IN_BYTES &&
3971                     is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
3972                     SvUTF8_on(sv);
3973
3974                 /* And if "Foo::", then that's what it certainly is. */
3975
3976                 if (len)
3977                     goto safe_bareword;
3978
3979                 /* See if it's the indirect object for a list operator. */
3980
3981                 if (PL_oldoldbufptr &&
3982                     PL_oldoldbufptr < PL_bufptr &&
3983                     (PL_oldoldbufptr == PL_last_lop
3984                      || PL_oldoldbufptr == PL_last_uni) &&
3985                     /* NO SKIPSPACE BEFORE HERE! */
3986                     (PL_expect == XREF ||
3987                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3988                 {
3989                     bool immediate_paren = *s == '(';
3990
3991                     /* (Now we can afford to cross potential line boundary.) */
3992                     s = skipspace(s);
3993
3994                     /* Two barewords in a row may indicate method call. */
3995
3996                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3997                         return tmp;
3998
3999                     /* If not a declared subroutine, it's an indirect object. */
4000                     /* (But it's an indir obj regardless for sort.) */
4001
4002                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4003                          ((!gv || !GvCVu(gv)) &&
4004                         (PL_last_lop_op != OP_MAPSTART &&
4005                          PL_last_lop_op != OP_GREPSTART))))
4006                     {
4007                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4008                         goto bareword;
4009                     }
4010                 }
4011
4012                 PL_expect = XOPERATOR;
4013                 s = skipspace(s);
4014
4015                 /* Is this a word before a => operator? */
4016                 if (*s == '=' && s[1] == '>' && !pkgname) {
4017                     CLINE;
4018                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4019                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4020                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4021                     TERM(WORD);
4022                 }
4023
4024                 /* If followed by a paren, it's certainly a subroutine. */
4025                 if (*s == '(') {
4026                     CLINE;
4027                     if (gv && GvCVu(gv)) {
4028                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4029                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4030                             s = d + 1;
4031                             goto its_constant;
4032                         }
4033                     }
4034                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4035                     PL_expect = XOPERATOR;
4036                     force_next(WORD);
4037                     yylval.ival = 0;
4038                     TOKEN('&');
4039                 }
4040
4041                 /* If followed by var or block, call it a method (unless sub) */
4042
4043                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4044                     PL_last_lop = PL_oldbufptr;
4045                     PL_last_lop_op = OP_METHOD;
4046                     PREBLOCK(METHOD);
4047                 }
4048
4049                 /* If followed by a bareword, see if it looks like indir obj. */
4050
4051                 if (!orig_keyword
4052                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4053                         && (tmp = intuit_method(s,gv)))
4054                     return tmp;
4055
4056                 /* Not a method, so call it a subroutine (if defined) */
4057
4058                 if (gv && GvCVu(gv)) {
4059                     CV* cv;
4060                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4061                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4062                                 "Ambiguous use of -%s resolved as -&%s()",
4063                                 PL_tokenbuf, PL_tokenbuf);
4064                     /* Check for a constant sub */
4065                     cv = GvCV(gv);
4066                     if ((sv = cv_const_sv(cv))) {
4067                   its_constant:
4068                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4069                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4070                         yylval.opval->op_private = 0;
4071                         TOKEN(WORD);
4072                     }
4073
4074                     /* Resolve to GV now. */
4075                     op_free(yylval.opval);
4076                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4077                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4078                     PL_last_lop = PL_oldbufptr;
4079                     PL_last_lop_op = OP_ENTERSUB;
4080                     /* Is there a prototype? */
4081                     if (SvPOK(cv)) {
4082                         STRLEN len;
4083                         char *proto = SvPV((SV*)cv, len);
4084                         if (!len)
4085                             TERM(FUNC0SUB);
4086                         if (strEQ(proto, "$"))
4087                             OPERATOR(UNIOPSUB);
4088                         while (*proto == ';')
4089                             proto++;
4090                         if (*proto == '&' && *s == '{') {
4091                             sv_setpv(PL_subname, PL_curstash ? 
4092                                         "__ANON__" : "__ANON__::__ANON__");
4093                             PREBLOCK(LSTOPSUB);
4094                         }
4095                     }
4096                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4097                     PL_expect = XTERM;
4098                     force_next(WORD);
4099                     TOKEN(NOAMP);
4100                 }
4101
4102                 /* Call it a bare word */
4103
4104                 if (PL_hints & HINT_STRICT_SUBS)
4105                     yylval.opval->op_private |= OPpCONST_STRICT;
4106                 else {
4107                 bareword:
4108                     if (ckWARN(WARN_RESERVED)) {
4109                         if (lastchar != '-') {
4110                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4111                             if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4112                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4113                                        PL_tokenbuf);
4114                         }
4115                     }
4116                 }
4117
4118             safe_bareword:
4119                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4120                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4121                         "Operator or semicolon missing before %c%s",
4122                         lastchar, PL_tokenbuf);
4123                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4124                         "Ambiguous use of %c resolved as operator %c",
4125                         lastchar, lastchar);
4126                 }
4127                 TOKEN(WORD);
4128             }
4129
4130         case KEY___FILE__:
4131             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4132                                         newSVpv(CopFILE(PL_curcop),0));
4133             TERM(THING);
4134
4135         case KEY___LINE__:
4136             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4137                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4138             TERM(THING);
4139
4140         case KEY___PACKAGE__:
4141             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4142                                         (PL_curstash
4143                                          ? newSVsv(PL_curstname)
4144                                          : &PL_sv_undef));
4145             TERM(THING);
4146
4147         case KEY___DATA__:
4148         case KEY___END__: {
4149             GV *gv;
4150
4151             /*SUPPRESS 560*/
4152             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4153                 char *pname = "main";
4154                 if (PL_tokenbuf[2] == 'D')
4155                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4156                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4157                 GvMULTI_on(gv);
4158                 if (!GvIO(gv))
4159                     GvIOp(gv) = newIO();
4160                 IoIFP(GvIOp(gv)) = PL_rsfp;
4161 #if defined(HAS_FCNTL) && defined(F_SETFD)
4162                 {
4163                     int fd = PerlIO_fileno(PL_rsfp);
4164                     fcntl(fd,F_SETFD,fd >= 3);
4165                 }
4166 #endif
4167                 /* Mark this internal pseudo-handle as clean */
4168                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4169                 if (PL_preprocess)
4170                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4171                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4172                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4173                 else
4174                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4175 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4176                 /* if the script was opened in binmode, we need to revert
4177                  * it to text mode for compatibility; but only iff it has CRs
4178                  * XXX this is a questionable hack at best. */
4179                 if (PL_bufend-PL_bufptr > 2
4180                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4181                 {
4182                     Off_t loc = 0;
4183                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4184                         loc = PerlIO_tell(PL_rsfp);
4185                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
4186                     }
4187 #ifdef NETWARE
4188                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4189 #else
4190                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4191 #endif  /* NETWARE */
4192 #ifdef PERLIO_IS_STDIO /* really? */
4193 #  if defined(__BORLANDC__)
4194                         /* XXX see note in do_binmode() */
4195                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4196 #  endif
4197 #endif
4198                         if (loc > 0)
4199                             PerlIO_seek(PL_rsfp, loc, 0);
4200                     }
4201                 }
4202 #endif
4203 #ifdef PERLIO_LAYERS
4204                 if (!IN_BYTES) {
4205                     if (UTF)
4206                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4207                     else if (PL_encoding) {
4208                         SV *name;
4209                         dSP;
4210                         ENTER;
4211                         SAVETMPS;
4212                         PUSHMARK(sp);
4213                         EXTEND(SP, 1);
4214                         XPUSHs(PL_encoding);
4215                         PUTBACK;
4216                         call_method("name", G_SCALAR);
4217                         SPAGAIN;
4218                         name = POPs;
4219                         PUTBACK;
4220                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, 
4221                                             Perl_form(aTHX_ ":encoding(%"SVf")",
4222                                                       name));
4223                         FREETMPS;
4224                         LEAVE;
4225                     }
4226                 }
4227 #endif
4228                 PL_rsfp = Nullfp;
4229             }
4230             goto fake_eof;
4231         }
4232
4233         case KEY_AUTOLOAD:
4234         case KEY_DESTROY:
4235         case KEY_BEGIN:
4236         case KEY_CHECK:
4237         case KEY_INIT:
4238         case KEY_END:
4239             if (PL_expect == XSTATE) {
4240                 s = PL_bufptr;
4241                 goto really_sub;
4242             }
4243             goto just_a_word;
4244
4245         case KEY_CORE:
4246             if (*s == ':' && s[1] == ':') {
4247                 s += 2;
4248                 d = s;
4249                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4250                 if (!(tmp = keyword(PL_tokenbuf, len)))
4251                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4252                 if (tmp < 0)
4253                     tmp = -tmp;
4254                 goto reserved_word;
4255             }
4256             goto just_a_word;
4257
4258         case KEY_abs:
4259             UNI(OP_ABS);
4260
4261         case KEY_alarm:
4262             UNI(OP_ALARM);
4263
4264         case KEY_accept:
4265             LOP(OP_ACCEPT,XTERM);
4266
4267         case KEY_and:
4268             OPERATOR(ANDOP);
4269
4270         case KEY_atan2:
4271             LOP(OP_ATAN2,XTERM);
4272
4273         case KEY_bind:
4274             LOP(OP_BIND,XTERM);
4275
4276         case KEY_binmode:
4277             LOP(OP_BINMODE,XTERM);
4278
4279         case KEY_bless:
4280             LOP(OP_BLESS,XTERM);
4281
4282         case KEY_chop:
4283             UNI(OP_CHOP);
4284
4285         case KEY_continue:
4286             PREBLOCK(CONTINUE);
4287
4288         case KEY_chdir:
4289             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
4290             UNI(OP_CHDIR);
4291
4292         case KEY_close:
4293             UNI(OP_CLOSE);
4294
4295         case KEY_closedir:
4296             UNI(OP_CLOSEDIR);
4297
4298         case KEY_cmp:
4299             Eop(OP_SCMP);
4300
4301         case KEY_caller:
4302             UNI(OP_CALLER);
4303
4304         case KEY_crypt:
4305 #ifdef FCRYPT
4306             if (!PL_cryptseen) {
4307                 PL_cryptseen = TRUE;
4308                 init_des();
4309             }
4310 #endif
4311             LOP(OP_CRYPT,XTERM);
4312
4313         case KEY_chmod:
4314             LOP(OP_CHMOD,XTERM);
4315
4316         case KEY_chown:
4317             LOP(OP_CHOWN,XTERM);
4318
4319         case KEY_connect:
4320             LOP(OP_CONNECT,XTERM);
4321
4322         case KEY_chr:
4323             UNI(OP_CHR);
4324
4325         case KEY_cos:
4326             UNI(OP_COS);
4327
4328         case KEY_chroot:
4329             UNI(OP_CHROOT);
4330
4331         case KEY_do:
4332             s = skipspace(s);
4333             if (*s == '{')
4334                 PRETERMBLOCK(DO);
4335             if (*s != '\'')
4336                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4337             OPERATOR(DO);
4338
4339         case KEY_die:
4340             PL_hints |= HINT_BLOCK_SCOPE;
4341             LOP(OP_DIE,XTERM);
4342
4343         case KEY_defined:
4344             UNI(OP_DEFINED);
4345
4346         case KEY_delete:
4347             UNI(OP_DELETE);
4348
4349         case KEY_dbmopen:
4350             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4351             LOP(OP_DBMOPEN,XTERM);
4352
4353         case KEY_dbmclose:
4354             UNI(OP_DBMCLOSE);
4355
4356         case KEY_dump:
4357             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4358             LOOPX(OP_DUMP);
4359
4360         case KEY_else:
4361             PREBLOCK(ELSE);
4362
4363         case KEY_elsif:
4364             yylval.ival = CopLINE(PL_curcop);
4365             OPERATOR(ELSIF);
4366
4367         case KEY_eq:
4368             Eop(OP_SEQ);
4369
4370         case KEY_exists:
4371             UNI(OP_EXISTS);
4372         
4373         case KEY_exit:
4374             UNI(OP_EXIT);
4375
4376         case KEY_eval:
4377             s = skipspace(s);
4378             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4379             UNIBRACK(OP_ENTEREVAL);
4380
4381         case KEY_eof:
4382             UNI(OP_EOF);
4383
4384         case KEY_err:
4385             OPERATOR(DOROP);
4386
4387         case KEY_exp:
4388             UNI(OP_EXP);
4389
4390         case KEY_each:
4391             UNI(OP_EACH);
4392
4393         case KEY_exec:
4394             set_csh();
4395             LOP(OP_EXEC,XREF);
4396
4397         case KEY_endhostent:
4398             FUN0(OP_EHOSTENT);
4399
4400         case KEY_endnetent:
4401             FUN0(OP_ENETENT);
4402
4403         case KEY_endservent:
4404             FUN0(OP_ESERVENT);
4405
4406         case KEY_endprotoent:
4407             FUN0(OP_EPROTOENT);
4408
4409         case KEY_endpwent:
4410             FUN0(OP_EPWENT);
4411
4412         case KEY_endgrent:
4413             FUN0(OP_EGRENT);
4414
4415         case KEY_for:
4416         case KEY_foreach:
4417             yylval.ival = CopLINE(PL_curcop);
4418             s = skipspace(s);
4419             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4420                 char *p = s;
4421                 if ((PL_bufend - p) >= 3 &&
4422                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4423                     p += 2;
4424                 else if ((PL_bufend - p) >= 4 &&
4425                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4426                     p += 3;
4427                 p = skipspace(p);
4428                 if (isIDFIRST_lazy_if(p,UTF)) {
4429                     p = scan_ident(p, PL_bufend,
4430                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4431                     p = skipspace(p);
4432                 }
4433                 if (*p != '$')
4434                     Perl_croak(aTHX_ "Missing $ on loop variable");
4435             }
4436             OPERATOR(FOR);
4437
4438         case KEY_formline:
4439             LOP(OP_FORMLINE,XTERM);
4440
4441         case KEY_fork:
4442             FUN0(OP_FORK);
4443
4444         case KEY_fcntl:
4445             LOP(OP_FCNTL,XTERM);
4446
4447         case KEY_fileno:
4448             UNI(OP_FILENO);
4449
4450         case KEY_flock:
4451             LOP(OP_FLOCK,XTERM);
4452
4453         case KEY_gt:
4454             Rop(OP_SGT);
4455
4456         case KEY_ge:
4457             Rop(OP_SGE);
4458
4459         case KEY_grep:
4460             LOP(OP_GREPSTART, XREF);
4461
4462         case KEY_goto:
4463             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4464             LOOPX(OP_GOTO);
4465
4466         case KEY_gmtime:
4467             UNI(OP_GMTIME);
4468
4469         case KEY_getc:
4470             UNIDOR(OP_GETC);
4471
4472         case KEY_getppid:
4473             FUN0(OP_GETPPID);
4474
4475         case KEY_getpgrp:
4476             UNI(OP_GETPGRP);
4477
4478         case KEY_getpriority:
4479             LOP(OP_GETPRIORITY,XTERM);
4480
4481         case KEY_getprotobyname:
4482             UNI(OP_GPBYNAME);
4483
4484         case KEY_getprotobynumber:
4485             LOP(OP_GPBYNUMBER,XTERM);
4486
4487         case KEY_getprotoent:
4488             FUN0(OP_GPROTOENT);
4489
4490         case KEY_getpwent:
4491             FUN0(OP_GPWENT);
4492
4493         case KEY_getpwnam:
4494             UNI(OP_GPWNAM);
4495
4496         case KEY_getpwuid:
4497             UNI(OP_GPWUID);
4498
4499         case KEY_getpeername:
4500             UNI(OP_GETPEERNAME);
4501
4502         case KEY_gethostbyname:
4503             UNI(OP_GHBYNAME);
4504
4505         case KEY_gethostbyaddr:
4506             LOP(OP_GHBYADDR,XTERM);
4507
4508         case KEY_gethostent:
4509             FUN0(OP_GHOSTENT);
4510
4511         case KEY_getnetbyname:
4512             UNI(OP_GNBYNAME);
4513
4514         case KEY_getnetbyaddr:
4515             LOP(OP_GNBYADDR,XTERM);
4516
4517         case KEY_getnetent:
4518             FUN0(OP_GNETENT);
4519
4520         case KEY_getservbyname:
4521             LOP(OP_GSBYNAME,XTERM);
4522
4523         case KEY_getservbyport:
4524             LOP(OP_GSBYPORT,XTERM);
4525
4526         case KEY_getservent:
4527             FUN0(OP_GSERVENT);
4528
4529         case KEY_getsockname:
4530             UNI(OP_GETSOCKNAME);
4531
4532         case KEY_getsockopt:
4533             LOP(OP_GSOCKOPT,XTERM);
4534
4535         case KEY_getgrent:
4536             FUN0(OP_GGRENT);
4537
4538         case KEY_getgrnam:
4539             UNI(OP_GGRNAM);
4540
4541         case KEY_getgrgid:
4542             UNI(OP_GGRGID);
4543
4544         case KEY_getlogin:
4545             FUN0(OP_GETLOGIN);
4546
4547         case KEY_glob:
4548             set_csh();
4549             LOP(OP_GLOB,XTERM);
4550
4551         case KEY_hex:
4552             UNI(OP_HEX);
4553
4554         case KEY_if:
4555             yylval.ival = CopLINE(PL_curcop);
4556             OPERATOR(IF);
4557
4558         case KEY_index:
4559             LOP(OP_INDEX,XTERM);
4560
4561         case KEY_int:
4562             UNI(OP_INT);
4563
4564         case KEY_ioctl:
4565             LOP(OP_IOCTL,XTERM);
4566
4567         case KEY_join:
4568             LOP(OP_JOIN,XTERM);
4569
4570         case KEY_keys:
4571             UNI(OP_KEYS);
4572
4573         case KEY_kill:
4574             LOP(OP_KILL,XTERM);
4575
4576         case KEY_last:
4577             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4578             LOOPX(OP_LAST);
4579         
4580         case KEY_lc:
4581             UNI(OP_LC);
4582
4583         case KEY_lcfirst:
4584             UNI(OP_LCFIRST);
4585
4586         case KEY_local:
4587             yylval.ival = 0;
4588             OPERATOR(LOCAL);
4589
4590         case KEY_length:
4591             UNI(OP_LENGTH);
4592
4593         case KEY_lt:
4594             Rop(OP_SLT);
4595
4596         case KEY_le:
4597             Rop(OP_SLE);
4598
4599         case KEY_localtime:
4600             UNI(OP_LOCALTIME);
4601
4602         case KEY_log:
4603             UNI(OP_LOG);
4604
4605         case KEY_link:
4606             LOP(OP_LINK,XTERM);
4607
4608         case KEY_listen:
4609             LOP(OP_LISTEN,XTERM);
4610
4611         case KEY_lock:
4612             UNI(OP_LOCK);
4613
4614         case KEY_lstat:
4615             UNI(OP_LSTAT);
4616
4617         case KEY_m:
4618             s = scan_pat(s,OP_MATCH);
4619             TERM(sublex_start());
4620
4621         case KEY_map:
4622             LOP(OP_MAPSTART, XREF);
4623
4624         case KEY_mkdir:
4625             LOP(OP_MKDIR,XTERM);
4626
4627         case KEY_msgctl:
4628             LOP(OP_MSGCTL,XTERM);
4629
4630         case KEY_msgget:
4631             LOP(OP_MSGGET,XTERM);
4632
4633         case KEY_msgrcv:
4634             LOP(OP_MSGRCV,XTERM);
4635
4636         case KEY_msgsnd:
4637             LOP(OP_MSGSND,XTERM);
4638
4639         case KEY_our:
4640         case KEY_my:
4641             PL_in_my = tmp;
4642             s = skipspace(s);
4643             if (isIDFIRST_lazy_if(s,UTF)) {
4644                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4645                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4646                     goto really_sub;
4647                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4648                 if (!PL_in_my_stash) {
4649                     char tmpbuf[1024];
4650                     PL_bufptr = s;
4651                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4652                     yyerror(tmpbuf);
4653                 }
4654             }
4655             yylval.ival = 1;
4656             OPERATOR(MY);
4657
4658         case KEY_next:
4659             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4660             LOOPX(OP_NEXT);
4661
4662         case KEY_ne:
4663             Eop(OP_SNE);
4664
4665         case KEY_no:
4666             if (PL_expect != XSTATE)
4667                 yyerror("\"no\" not allowed in expression");
4668             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4669             s = force_version(s, FALSE);
4670             yylval.ival = 0;
4671             OPERATOR(USE);
4672
4673         case KEY_not:
4674             if (*s == '(' || (s = skipspace(s), *s == '('))
4675                 FUN1(OP_NOT);
4676             else
4677                 OPERATOR(NOTOP);
4678
4679         case KEY_open:
4680             s = skipspace(s);
4681             if (isIDFIRST_lazy_if(s,UTF)) {
4682                 char *t;
4683                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4684                 t = skipspace(d);
4685                 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4686                     /* [perl #16184] */
4687                     && !(t[0] == '=' && t[1] == '>')
4688                 ) {
4689                     Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4690                            "Precedence problem: open %.*s should be open(%.*s)",
4691                             d - s, s, d - s, s);
4692                 }
4693             }
4694             LOP(OP_OPEN,XTERM);
4695
4696         case KEY_or:
4697             yylval.ival = OP_OR;
4698             OPERATOR(OROP);
4699
4700         case KEY_ord:
4701             UNI(OP_ORD);
4702
4703         case KEY_oct:
4704             UNI(OP_OCT);
4705
4706         case KEY_opendir:
4707             LOP(OP_OPEN_DIR,XTERM);
4708
4709         case KEY_print:
4710             checkcomma(s,PL_tokenbuf,"filehandle");
4711             LOP(OP_PRINT,XREF);
4712
4713         case KEY_printf:
4714             checkcomma(s,PL_tokenbuf,"filehandle");
4715             LOP(OP_PRTF,XREF);
4716
4717         case KEY_prototype:
4718             UNI(OP_PROTOTYPE);
4719
4720         case KEY_push:
4721             LOP(OP_PUSH,XTERM);
4722
4723         case KEY_pop:
4724             UNIDOR(OP_POP);
4725
4726         case KEY_pos:
4727             UNIDOR(OP_POS);
4728         
4729         case KEY_pack:
4730             LOP(OP_PACK,XTERM);
4731
4732         case KEY_package:
4733             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4734             OPERATOR(PACKAGE);
4735
4736         case KEY_pipe:
4737             LOP(OP_PIPE_OP,XTERM);
4738
4739         case KEY_q:
4740             s = scan_str(s,FALSE,FALSE);
4741             if (!s)
4742                 missingterm((char*)0);
4743             yylval.ival = OP_CONST;
4744             TERM(sublex_start());
4745
4746         case KEY_quotemeta:
4747             UNI(OP_QUOTEMETA);
4748
4749         case KEY_qw:
4750             s = scan_str(s,FALSE,FALSE);
4751             if (!s)
4752                 missingterm((char*)0);
4753             force_next(')');
4754             if (SvCUR(PL_lex_stuff)) {
4755                 OP *words = Nullop;
4756                 int warned = 0;
4757                 d = SvPV_force(PL_lex_stuff, len);
4758                 while (len) {
4759                     SV *sv;
4760                     for (; isSPACE(*d) && len; --len, ++d) ;
4761                     if (len) {
4762                         char *b = d;
4763                         if (!warned && ckWARN(WARN_QW)) {
4764                             for (; !isSPACE(*d) && len; --len, ++d) {
4765                                 if (*d == ',') {
4766                                     Perl_warner(aTHX_ packWARN(WARN_QW),
4767                                         "Possible attempt to separate words with commas");
4768                                     ++warned;
4769                                 }
4770                                 else if (*d == '#') {
4771                                     Perl_warner(aTHX_ packWARN(WARN_QW),
4772                                         "Possible attempt to put comments in qw() list");
4773                                     ++warned;
4774                                 }
4775                             }
4776                         }
4777                         else {
4778                             for (; !isSPACE(*d) && len; --len, ++d) ;
4779                         }
4780                         sv = newSVpvn(b, d-b);
4781                         if (DO_UTF8(PL_lex_stuff))
4782                             SvUTF8_on(sv);
4783                         words = append_elem(OP_LIST, words,
4784                                             newSVOP(OP_CONST, 0, tokeq(sv)));
4785                     }
4786                 }
4787                 if (words) {
4788                     PL_nextval[PL_nexttoke].opval = words;
4789                     force_next(THING);
4790                 }
4791             }
4792             if (PL_lex_stuff) {
4793                 SvREFCNT_dec(PL_lex_stuff);
4794                 PL_lex_stuff = Nullsv;
4795             }
4796             PL_expect = XTERM;
4797             TOKEN('(');
4798
4799         case KEY_qq:
4800             s = scan_str(s,FALSE,FALSE);
4801             if (!s)
4802                 missingterm((char*)0);
4803             yylval.ival = OP_STRINGIFY;
4804             if (SvIVX(PL_lex_stuff) == '\'')
4805                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
4806             TERM(sublex_start());
4807
4808         case KEY_qr:
4809             s = scan_pat(s,OP_QR);
4810             TERM(sublex_start());
4811
4812         case KEY_qx:
4813             s = scan_str(s,FALSE,FALSE);
4814             if (!s)
4815                 missingterm((char*)0);
4816             yylval.ival = OP_BACKTICK;
4817             set_csh();
4818             TERM(sublex_start());
4819
4820         case KEY_return:
4821             OLDLOP(OP_RETURN);
4822
4823         case KEY_require:
4824             s = skipspace(s);
4825             if (isDIGIT(*s)) {
4826                 s = force_version(s, FALSE);
4827             }
4828             else if (*s != 'v' || !isDIGIT(s[1])
4829                     || (s = force_version(s, TRUE), *s == 'v'))
4830             {
4831                 *PL_tokenbuf = '\0';
4832                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4833                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4834                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4835                 else if (*s == '<')
4836                     yyerror("<> should be quotes");
4837             }
4838             UNI(OP_REQUIRE);
4839
4840         case KEY_reset:
4841             UNI(OP_RESET);
4842
4843         case KEY_redo:
4844             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4845             LOOPX(OP_REDO);
4846
4847         case KEY_rename:
4848             LOP(OP_RENAME,XTERM);
4849
4850         case KEY_rand:
4851             UNI(OP_RAND);
4852
4853         case KEY_rmdir:
4854             UNI(OP_RMDIR);
4855
4856         case KEY_rindex:
4857             LOP(OP_RINDEX,XTERM);
4858
4859         case KEY_read:
4860             LOP(OP_READ,XTERM);
4861
4862         case KEY_readdir:
4863             UNI(OP_READDIR);
4864
4865         case KEY_readline:
4866             set_csh();
4867             UNIDOR(OP_READLINE);
4868
4869         case KEY_readpipe:
4870             set_csh();
4871             UNI(OP_BACKTICK);
4872
4873         case KEY_rewinddir:
4874             UNI(OP_REWINDDIR);
4875
4876         case KEY_recv:
4877             LOP(OP_RECV,XTERM);
4878
4879         case KEY_reverse:
4880             LOP(OP_REVERSE,XTERM);
4881
4882         case KEY_readlink:
4883             UNIDOR(OP_READLINK);
4884
4885         case KEY_ref:
4886             UNI(OP_REF);
4887
4888         case KEY_s:
4889             s = scan_subst(s);
4890             if (yylval.opval)
4891                 TERM(sublex_start());
4892             else
4893                 TOKEN(1);       /* force error */
4894
4895         case KEY_chomp:
4896             UNI(OP_CHOMP);
4897         
4898         case KEY_scalar:
4899             UNI(OP_SCALAR);
4900
4901         case KEY_select:
4902             LOP(OP_SELECT,XTERM);
4903
4904         case KEY_seek:
4905             LOP(OP_SEEK,XTERM);
4906
4907         case KEY_semctl:
4908             LOP(OP_SEMCTL,XTERM);
4909
4910         case KEY_semget:
4911             LOP(OP_SEMGET,XTERM);
4912
4913         case KEY_semop:
4914             LOP(OP_SEMOP,XTERM);
4915
4916         case KEY_send:
4917             LOP(OP_SEND,XTERM);
4918
4919         case KEY_setpgrp:
4920             LOP(OP_SETPGRP,XTERM);
4921
4922         case KEY_setpriority:
4923             LOP(OP_SETPRIORITY,XTERM);
4924
4925         case KEY_sethostent:
4926             UNI(OP_SHOSTENT);
4927
4928         case KEY_setnetent:
4929             UNI(OP_SNETENT);
4930
4931         case KEY_setservent:
4932             UNI(OP_SSERVENT);
4933
4934         case KEY_setprotoent:
4935             UNI(OP_SPROTOENT);
4936
4937         case KEY_setpwent:
4938             FUN0(OP_SPWENT);
4939
4940         case KEY_setgrent:
4941             FUN0(OP_SGRENT);
4942
4943         case KEY_seekdir:
4944             LOP(OP_SEEKDIR,XTERM);
4945
4946         case KEY_setsockopt:
4947             LOP(OP_SSOCKOPT,XTERM);
4948
4949         case KEY_shift:
4950             UNIDOR(OP_SHIFT);
4951
4952         case KEY_shmctl:
4953             LOP(OP_SHMCTL,XTERM);
4954
4955         case KEY_shmget:
4956             LOP(OP_SHMGET,XTERM);
4957
4958         case KEY_shmread:
4959             LOP(OP_SHMREAD,XTERM);
4960
4961         case KEY_shmwrite:
4962             LOP(OP_SHMWRITE,XTERM);
4963
4964         case KEY_shutdown:
4965             LOP(OP_SHUTDOWN,XTERM);
4966
4967         case KEY_sin:
4968             UNI(OP_SIN);
4969
4970         case KEY_sleep:
4971             UNI(OP_SLEEP);
4972
4973         case KEY_socket:
4974             LOP(OP_SOCKET,XTERM);
4975
4976         case KEY_socketpair:
4977             LOP(OP_SOCKPAIR,XTERM);
4978
4979         case KEY_sort:
4980             checkcomma(s,PL_tokenbuf,"subroutine name");
4981             s = skipspace(s);
4982             if (*s == ';' || *s == ')')         /* probably a close */
4983                 Perl_croak(aTHX_ "sort is now a reserved word");
4984             PL_expect = XTERM;
4985             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4986             LOP(OP_SORT,XREF);
4987
4988         case KEY_split:
4989             LOP(OP_SPLIT,XTERM);
4990
4991         case KEY_sprintf:
4992             LOP(OP_SPRINTF,XTERM);
4993
4994         case KEY_splice:
4995             LOP(OP_SPLICE,XTERM);
4996
4997         case KEY_sqrt:
4998             UNI(OP_SQRT);
4999
5000         case KEY_srand:
5001             UNI(OP_SRAND);
5002
5003         case KEY_stat:
5004             UNI(OP_STAT);
5005
5006         case KEY_study:
5007             UNI(OP_STUDY);
5008
5009         case KEY_substr:
5010             LOP(OP_SUBSTR,XTERM);
5011
5012         case KEY_format:
5013         case KEY_sub:
5014           really_sub:
5015             {
5016                 char tmpbuf[sizeof PL_tokenbuf];
5017                 SSize_t tboffset = 0;
5018                 expectation attrful;
5019                 bool have_name, have_proto, bad_proto;
5020                 int key = tmp;
5021
5022                 s = skipspace(s);
5023
5024                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5025                     (*s == ':' && s[1] == ':'))
5026                 {
5027                     PL_expect = XBLOCK;
5028                     attrful = XATTRBLOCK;
5029                     /* remember buffer pos'n for later force_word */
5030                     tboffset = s - PL_oldbufptr;
5031                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5032                     if (strchr(tmpbuf, ':'))
5033                         sv_setpv(PL_subname, tmpbuf);
5034                     else {
5035                         sv_setsv(PL_subname,PL_curstname);
5036                         sv_catpvn(PL_subname,"::",2);
5037                         sv_catpvn(PL_subname,tmpbuf,len);
5038                     }
5039                     s = skipspace(d);
5040                     have_name = TRUE;
5041                 }
5042                 else {
5043                     if (key == KEY_my)
5044                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
5045                     PL_expect = XTERMBLOCK;
5046                     attrful = XATTRTERM;
5047                     sv_setpv(PL_subname,"?");
5048                     have_name = FALSE;
5049                 }
5050
5051                 if (key == KEY_format) {
5052                     if (*s == '=')
5053                         PL_lex_formbrack = PL_lex_brackets + 1;
5054                     if (have_name)
5055                         (void) force_word(PL_oldbufptr + tboffset, WORD,
5056                                           FALSE, TRUE, TRUE);
5057                     OPERATOR(FORMAT);
5058                 }
5059
5060                 /* Look for a prototype */
5061                 if (*s == '(') {
5062                     char *p;
5063
5064                     s = scan_str(s,FALSE,FALSE);
5065                     if (!s)
5066                         Perl_croak(aTHX_ "Prototype not terminated");
5067                     /* strip spaces and check for bad characters */
5068                     d = SvPVX(PL_lex_stuff);
5069                     tmp = 0;
5070                     bad_proto = FALSE;
5071                     for (p = d; *p; ++p) {
5072                         if (!isSPACE(*p)) {
5073                             d[tmp++] = *p;
5074                             if (!strchr("$@%*;[]&\\", *p))
5075                                 bad_proto = TRUE;
5076                         }
5077                     }
5078                     d[tmp] = '\0';
5079                     if (bad_proto && ckWARN(WARN_SYNTAX))
5080                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5081                                     "Illegal character in prototype for %"SVf" : %s",
5082                                     PL_subname, d);
5083                     SvCUR(PL_lex_stuff) = tmp;
5084                     have_proto = TRUE;
5085
5086                     s = skipspace(s);
5087                 }
5088                 else
5089                     have_proto = FALSE;
5090
5091                 if (*s == ':' && s[1] != ':')
5092                     PL_expect = attrful;
5093                 else if (!have_name && *s != '{' && key == KEY_sub)
5094                     Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5095
5096                 if (have_proto) {
5097                     PL_nextval[PL_nexttoke].opval =
5098                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5099                     PL_lex_stuff = Nullsv;
5100                     force_next(THING);
5101                 }
5102                 if (!have_name) {
5103                     sv_setpv(PL_subname,
5104                         PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5105                     TOKEN(ANONSUB);
5106                 }
5107                 (void) force_word(PL_oldbufptr + tboffset, WORD,
5108                                   FALSE, TRUE, TRUE);
5109                 if (key == KEY_my)
5110                     TOKEN(MYSUB);
5111                 TOKEN(SUB);
5112             }
5113
5114         case KEY_system:
5115             set_csh();
5116             LOP(OP_SYSTEM,XREF);
5117
5118         case KEY_symlink:
5119             LOP(OP_SYMLINK,XTERM);
5120
5121         case KEY_syscall:
5122             LOP(OP_SYSCALL,XTERM);
5123
5124         case KEY_sysopen:
5125             LOP(OP_SYSOPEN,XTERM);
5126
5127         case KEY_sysseek:
5128             LOP(OP_SYSSEEK,XTERM);
5129
5130         case KEY_sysread:
5131             LOP(OP_SYSREAD,XTERM);
5132
5133         case KEY_syswrite:
5134             LOP(OP_SYSWRITE,XTERM);
5135
5136         case KEY_tr:
5137             s = scan_trans(s);
5138             TERM(sublex_start());
5139
5140         case KEY_tell:
5141             UNI(OP_TELL);
5142
5143         case KEY_telldir:
5144             UNI(OP_TELLDIR);
5145
5146         case KEY_tie:
5147             LOP(OP_TIE,XTERM);
5148
5149         case KEY_tied:
5150             UNI(OP_TIED);
5151
5152         case KEY_time:
5153             FUN0(OP_TIME);
5154
5155         case KEY_times:
5156             FUN0(OP_TMS);
5157
5158         case KEY_truncate:
5159             LOP(OP_TRUNCATE,XTERM);
5160
5161         case KEY_uc:
5162             UNI(OP_UC);
5163
5164         case KEY_ucfirst:
5165             UNI(OP_UCFIRST);
5166
5167         case KEY_untie:
5168             UNI(OP_UNTIE);
5169
5170         case KEY_until:
5171             yylval.ival = CopLINE(PL_curcop);
5172             OPERATOR(UNTIL);
5173
5174         case KEY_unless:
5175             yylval.ival = CopLINE(PL_curcop);
5176             OPERATOR(UNLESS);
5177
5178         case KEY_unlink:
5179             LOP(OP_UNLINK,XTERM);
5180
5181         case KEY_undef:
5182             UNIDOR(OP_UNDEF);
5183
5184         case KEY_unpack:
5185             LOP(OP_UNPACK,XTERM);
5186
5187         case KEY_utime:
5188             LOP(OP_UTIME,XTERM);
5189
5190         case KEY_umask:
5191             UNIDOR(OP_UMASK);
5192
5193         case KEY_unshift:
5194             LOP(OP_UNSHIFT,XTERM);
5195
5196         case KEY_use:
5197             if (PL_expect != XSTATE)
5198                 yyerror("\"use\" not allowed in expression");
5199             s = skipspace(s);
5200             if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5201                 s = force_version(s, TRUE);
5202                 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5203                     PL_nextval[PL_nexttoke].opval = Nullop;
5204                     force_next(WORD);
5205                 }
5206                 else if (*s == 'v') {
5207                     s = force_word(s,WORD,FALSE,TRUE,FALSE);
5208                     s = force_version(s, FALSE);
5209                 }
5210             }
5211             else {
5212                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5213                 s = force_version(s, FALSE);
5214             }
5215             yylval.ival = 1;
5216             OPERATOR(USE);
5217
5218         case KEY_values:
5219             UNI(OP_VALUES);
5220
5221         case KEY_vec:
5222             LOP(OP_VEC,XTERM);
5223
5224         case KEY_while:
5225             yylval.ival = CopLINE(PL_curcop);
5226             OPERATOR(WHILE);
5227
5228         case KEY_warn:
5229             PL_hints |= HINT_BLOCK_SCOPE;
5230             LOP(OP_WARN,XTERM);
5231
5232         case KEY_wait:
5233             FUN0(OP_WAIT);
5234
5235         case KEY_waitpid:
5236             LOP(OP_WAITPID,XTERM);
5237
5238         case KEY_wantarray:
5239             FUN0(OP_WANTARRAY);
5240
5241         case KEY_write:
5242 #ifdef EBCDIC
5243         {
5244             char ctl_l[2];
5245             ctl_l[0] = toCTRL('L');
5246             ctl_l[1] = '\0';
5247             gv_fetchpv(ctl_l,TRUE, SVt_PV);
5248         }
5249 #else
5250             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
5251 #endif
5252             UNI(OP_ENTERWRITE);
5253
5254         case KEY_x:
5255             if (PL_expect == XOPERATOR)
5256                 Mop(OP_REPEAT);
5257             check_uni();
5258             goto just_a_word;
5259
5260         case KEY_xor:
5261             yylval.ival = OP_XOR;
5262             OPERATOR(OROP);
5263
5264         case KEY_y:
5265             s = scan_trans(s);
5266             TERM(sublex_start());
5267         }
5268     }}
5269 }
5270 #ifdef __SC__
5271 #pragma segment Main
5272 #endif
5273
5274 static int
5275 S_pending_ident(pTHX)
5276 {
5277     register char *d;
5278     register I32 tmp = 0;
5279     /* pit holds the identifier we read and pending_ident is reset */
5280     char pit = PL_pending_ident;
5281     PL_pending_ident = 0;
5282
5283     DEBUG_T({ PerlIO_printf(Perl_debug_log,
5284           "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5285
5286     /* if we're in a my(), we can't allow dynamics here.
5287        $foo'bar has already been turned into $foo::bar, so
5288        just check for colons.
5289
5290        if it's a legal name, the OP is a PADANY.
5291     */
5292     if (PL_in_my) {
5293         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
5294             if (strchr(PL_tokenbuf,':'))
5295                 yyerror(Perl_form(aTHX_ "No package name allowed for "
5296                                   "variable %s in \"our\"",
5297                                   PL_tokenbuf));
5298             tmp = allocmy(PL_tokenbuf);
5299         }
5300         else {
5301             if (strchr(PL_tokenbuf,':'))
5302                 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5303
5304             yylval.opval = newOP(OP_PADANY, 0);
5305             yylval.opval->op_targ = allocmy(PL_tokenbuf);
5306             return PRIVATEREF;
5307         }
5308     }
5309
5310     /*
5311        build the ops for accesses to a my() variable.
5312
5313        Deny my($a) or my($b) in a sort block, *if* $a or $b is
5314        then used in a comparison.  This catches most, but not
5315        all cases.  For instance, it catches
5316            sort { my($a); $a <=> $b }
5317        but not
5318            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5319        (although why you'd do that is anyone's guess).
5320     */
5321
5322     if (!strchr(PL_tokenbuf,':')) {
5323         if (!PL_in_my)
5324             tmp = pad_findmy(PL_tokenbuf);
5325         if (tmp != NOT_IN_PAD) {
5326             /* might be an "our" variable" */
5327             if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5328                 /* build ops for a bareword */
5329                 SV *sym = newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)), 0);
5330                 sv_catpvn(sym, "::", 2);
5331                 sv_catpv(sym, PL_tokenbuf+1);
5332                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5333                 yylval.opval->op_private = OPpCONST_ENTERED;
5334                 gv_fetchpv(SvPVX(sym),
5335                     (PL_in_eval
5336                         ? (GV_ADDMULTI | GV_ADDINEVAL)
5337                         : GV_ADDMULTI
5338                     ),
5339                     ((PL_tokenbuf[0] == '$') ? SVt_PV
5340                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5341                      : SVt_PVHV));
5342                 return WORD;
5343             }
5344
5345             /* if it's a sort block and they're naming $a or $b */
5346             if (PL_last_lop_op == OP_SORT &&
5347                 PL_tokenbuf[0] == '$' &&
5348                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5349                 && !PL_tokenbuf[2])
5350             {
5351                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5352                      d < PL_bufend && *d != '\n';
5353                      d++)
5354                 {
5355                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5356                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5357                               PL_tokenbuf);
5358                     }
5359                 }
5360             }
5361
5362             yylval.opval = newOP(OP_PADANY, 0);
5363             yylval.opval->op_targ = tmp;
5364             return PRIVATEREF;
5365         }
5366     }
5367
5368     /*
5369        Whine if they've said @foo in a doublequoted string,
5370        and @foo isn't a variable we can find in the symbol
5371        table.
5372     */
5373     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5374         GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5375         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5376              && ckWARN(WARN_AMBIGUOUS))
5377         {
5378             /* Downgraded from fatal to warning 20000522 mjd */
5379             Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5380                         "Possible unintended interpolation of %s in string",
5381                          PL_tokenbuf);
5382         }
5383     }
5384
5385     /* build ops for a bareword */
5386     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5387     yylval.opval->op_private = OPpCONST_ENTERED;
5388     gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5389                ((PL_tokenbuf[0] == '$') ? SVt_PV
5390                 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5391                 : SVt_PVHV));
5392     return WORD;
5393 }
5394
5395 I32
5396 Perl_keyword(pTHX_ register char *d, I32 len)
5397 {
5398     switch (*d) {
5399     case '_':
5400         if (d[1] == '_') {
5401             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
5402             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
5403             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
5404             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
5405             if (strEQ(d,"__END__"))             return KEY___END__;
5406         }
5407         break;
5408     case 'A':
5409         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
5410         break;
5411     case 'a':
5412         switch (len) {
5413         case 3:
5414             if (strEQ(d,"and"))                 return -KEY_and;
5415             if (strEQ(d,"abs"))                 return -KEY_abs;
5416             break;
5417         case 5:
5418             if (strEQ(d,"alarm"))               return -KEY_alarm;
5419             if (strEQ(d,"atan2"))               return -KEY_atan2;
5420             break;
5421         case 6:
5422             if (strEQ(d,"accept"))              return -KEY_accept;
5423             break;
5424         }
5425         break;
5426     case 'B':
5427         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
5428         break;
5429     case 'b':
5430         if (strEQ(d,"bless"))                   return -KEY_bless;
5431         if (strEQ(d,"bind"))                    return -KEY_bind;
5432         if (strEQ(d,"binmode"))                 return -KEY_binmode;
5433         break;
5434     case 'C':
5435         if (strEQ(d,"CORE"))                    return -KEY_CORE;
5436         if (strEQ(d,"CHECK"))                   return KEY_CHECK;
5437         break;
5438     case 'c':
5439         switch (len) {
5440         case 3:
5441             if (strEQ(d,"cmp"))                 return -KEY_cmp;
5442             if (strEQ(d,"chr"))                 return -KEY_chr;
5443             if (strEQ(d,"cos"))                 return -KEY_cos;
5444             break;
5445         case 4:
5446             if (strEQ(d,"chop"))                return -KEY_chop;
5447             break;
5448         case 5:
5449             if (strEQ(d,"close"))               return -KEY_close;
5450             if (strEQ(d,"chdir"))               return -KEY_chdir;
5451             if (strEQ(d,"chomp"))               return -KEY_chomp;
5452             if (strEQ(d,"chmod"))               return -KEY_chmod;
5453             if (strEQ(d,"chown"))               return -KEY_chown;
5454             if (strEQ(d,"crypt"))               return -KEY_crypt;
5455             break;
5456         case 6:
5457             if (strEQ(d,"chroot"))              return -KEY_chroot;
5458             if (strEQ(d,"caller"))              return -KEY_caller;
5459             break;
5460         case 7:
5461             if (strEQ(d,"connect"))             return -KEY_connect;
5462             break;
5463         case 8:
5464             if (strEQ(d,"closedir"))            return -KEY_closedir;
5465             if (strEQ(d,"continue"))            return -KEY_continue;
5466             break;
5467         }
5468         break;
5469     case 'D':
5470         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
5471         break;
5472     case 'd':
5473         switch (len) {
5474         case 2:
5475             if (strEQ(d,"do"))                  return KEY_do;
5476             break;
5477         case 3:
5478             if (strEQ(d,"die"))                 return -KEY_die;
5479             break;
5480         case 4:
5481             if (strEQ(d,"dump"))                return -KEY_dump;
5482             break;
5483         case 6:
5484             if (strEQ(d,"delete"))              return KEY_delete;
5485             break;
5486         case 7:
5487             if (strEQ(d,"defined"))             return KEY_defined;
5488             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
5489             break;
5490         case 8:
5491             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
5492             break;
5493         }
5494         break;
5495     case 'E':
5496         if (strEQ(d,"END"))                     return KEY_END;
5497         break;
5498     case 'e':
5499         switch (len) {
5500         case 2:
5501             if (strEQ(d,"eq"))                  return -KEY_eq;
5502             break;
5503         case 3:
5504             if (strEQ(d,"eof"))                 return -KEY_eof;
5505             if (strEQ(d,"err"))                 return -KEY_err;
5506             if (strEQ(d,"exp"))                 return -KEY_exp;
5507             break;
5508         case 4:
5509             if (strEQ(d,"else"))                return KEY_else;
5510             if (strEQ(d,"exit"))                return -KEY_exit;
5511             if (strEQ(d,"eval"))                return KEY_eval;
5512             if (strEQ(d,"exec"))                return -KEY_exec;
5513            if (strEQ(d,"each"))                return -KEY_each;
5514             break;
5515         case 5:
5516             if (strEQ(d,"elsif"))               return KEY_elsif;
5517             break;
5518         case 6:
5519             if (strEQ(d,"exists"))              return KEY_exists;
5520             if (strEQ(d,"elseif") && ckWARN_d(WARN_SYNTAX))
5521                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5522                         "elseif should be elsif");
5523             break;
5524         case 8:
5525             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
5526             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
5527             break;
5528         case 9:
5529             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
5530             break;
5531         case 10:
5532             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
5533             if (strEQ(d,"endservent"))          return -KEY_endservent;
5534             break;
5535         case 11:
5536             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
5537             break;
5538         }
5539         break;
5540     case 'f':
5541         switch (len) {
5542         case 3:
5543             if (strEQ(d,"for"))                 return KEY_for;
5544             break;
5545         case 4:
5546             if (strEQ(d,"fork"))                return -KEY_fork;
5547             break;
5548         case 5:
5549             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
5550             if (strEQ(d,"flock"))               return -KEY_flock;
5551             break;
5552         case 6:
5553             if (strEQ(d,"format"))              return KEY_format;
5554             if (strEQ(d,"fileno"))              return -KEY_fileno;
5555             break;
5556         case 7:
5557             if (strEQ(d,"foreach"))             return KEY_foreach;
5558             break;
5559         case 8:
5560             if (strEQ(d,"formline"))            return -KEY_formline;
5561             break;
5562         }
5563         break;
5564     case 'g':
5565         if (strnEQ(d,"get",3)) {
5566             d += 3;
5567             if (*d == 'p') {
5568                 switch (len) {
5569                 case 7:
5570                     if (strEQ(d,"ppid"))        return -KEY_getppid;
5571                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
5572                     break;
5573                 case 8:
5574                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
5575                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
5576                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
5577                     break;
5578                 case 11:
5579                     if (strEQ(d,"peername"))    return -KEY_getpeername;
5580                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
5581                     if (strEQ(d,"priority"))    return -KEY_getpriority;
5582                     break;
5583                 case 14:
5584                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5585                     break;
5586                 case 16:
5587                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5588                     break;
5589                 }
5590             }
5591             else if (*d == 'h') {
5592                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
5593                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
5594                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
5595             }
5596             else if (*d == 'n') {
5597                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
5598                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
5599                 if (strEQ(d,"netent"))          return -KEY_getnetent;
5600             }
5601             else if (*d == 's') {
5602                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
5603                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
5604                 if (strEQ(d,"servent"))         return -KEY_getservent;
5605                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
5606                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
5607             }
5608             else if (*d == 'g') {
5609                 if (strEQ(d,"grent"))           return -KEY_getgrent;
5610                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
5611                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
5612             }
5613             else if (*d == 'l') {
5614                 if (strEQ(d,"login"))           return -KEY_getlogin;
5615             }
5616             else if (strEQ(d,"c"))              return -KEY_getc;
5617             break;
5618         }
5619         switch (len) {
5620         case 2:
5621             if (strEQ(d,"gt"))                  return -KEY_gt;
5622             if (strEQ(d,"ge"))                  return -KEY_ge;
5623             break;
5624         case 4:
5625             if (strEQ(d,"grep"))                return KEY_grep;
5626             if (strEQ(d,"goto"))                return KEY_goto;
5627             if (strEQ(d,"glob"))                return KEY_glob;
5628             break;
5629         case 6:
5630             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
5631             break;
5632         }
5633         break;
5634     case 'h':
5635         if (strEQ(d,"hex"))                     return -KEY_hex;
5636         break;
5637     case 'I':
5638         if (strEQ(d,"INIT"))                    return KEY_INIT;
5639         break;
5640     case 'i':
5641         switch (len) {
5642         case 2:
5643             if (strEQ(d,"if"))                  return KEY_if;
5644             break;
5645         case 3:
5646             if (strEQ(d,"int"))                 return -KEY_int;
5647             break;
5648         case 5:
5649             if (strEQ(d,"index"))               return -KEY_index;
5650             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
5651             break;
5652         }
5653         break;
5654     case 'j':
5655         if (strEQ(d,"join"))                    return -KEY_join;
5656         break;
5657     case 'k':
5658         if (len == 4) {
5659            if (strEQ(d,"keys"))                return -KEY_keys;
5660             if (strEQ(d,"kill"))                return -KEY_kill;
5661         }
5662         break;
5663     case 'l':
5664         switch (len) {
5665         case 2:
5666             if (strEQ(d,"lt"))                  return -KEY_lt;
5667             if (strEQ(d,"le"))                  return -KEY_le;
5668             if (strEQ(d,"lc"))                  return -KEY_lc;
5669             break;
5670         case 3:
5671             if (strEQ(d,"log"))                 return -KEY_log;
5672             break;
5673         case 4:
5674             if (strEQ(d,"last"))                return KEY_last;
5675             if (strEQ(d,"link"))                return -KEY_link;
5676             if (strEQ(d,"lock"))                return -KEY_lock;
5677             break;
5678         case 5:
5679             if (strEQ(d,"local"))               return KEY_local;
5680             if (strEQ(d,"lstat"))               return -KEY_lstat;
5681             break;
5682         case 6:
5683             if (strEQ(d,"length"))              return -KEY_length;
5684             if (strEQ(d,"listen"))              return -KEY_listen;
5685             break;
5686         case 7:
5687             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
5688             break;
5689         case 9:
5690             if (strEQ(d,"localtime"))           return -KEY_localtime;
5691             break;
5692         }
5693         break;
5694     case 'm':
5695         switch (len) {
5696         case 1:                                 return KEY_m;
5697         case 2:
5698             if (strEQ(d,"my"))                  return KEY_my;
5699             break;
5700         case 3:
5701             if (strEQ(d,"map"))                 return KEY_map;
5702             break;
5703         case 5:
5704             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
5705             break;
5706         case 6:
5707             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
5708             if (strEQ(d,"msgget"))              return -KEY_msgget;
5709             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
5710             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
5711             break;
5712         }
5713         break;
5714     case 'n':
5715         if (strEQ(d,"next"))                    return KEY_next;
5716         if (strEQ(d,"ne"))                      return -KEY_ne;
5717         if (strEQ(d,"not"))                     return -KEY_not;
5718         if (strEQ(d,"no"))                      return KEY_no;
5719         break;
5720     case 'o':
5721         switch (len) {
5722         case 2:
5723             if (strEQ(d,"or"))                  return -KEY_or;
5724             break;
5725         case 3:
5726             if (strEQ(d,"ord"))                 return -KEY_ord;
5727             if (strEQ(d,"oct"))                 return -KEY_oct;
5728             if (strEQ(d,"our"))                 return KEY_our;
5729             break;
5730         case 4:
5731             if (strEQ(d,"open"))                return -KEY_open;
5732             break;
5733         case 7:
5734             if (strEQ(d,"opendir"))             return -KEY_opendir;
5735             break;
5736         }
5737         break;
5738     case 'p':
5739         switch (len) {
5740         case 3:
5741            if (strEQ(d,"pop"))                 return -KEY_pop;
5742             if (strEQ(d,"pos"))                 return KEY_pos;
5743             break;
5744         case 4:
5745            if (strEQ(d,"push"))                return -KEY_push;
5746             if (strEQ(d,"pack"))                return -KEY_pack;
5747             if (strEQ(d,"pipe"))                return -KEY_pipe;
5748             break;
5749         case 5:
5750             if (strEQ(d,"print"))               return KEY_print;
5751             break;
5752         case 6:
5753             if (strEQ(d,"printf"))              return KEY_printf;
5754             break;
5755         case 7:
5756             if (strEQ(d,"package"))             return KEY_package;
5757             break;
5758         case 9:
5759             if (strEQ(d,"prototype"))           return KEY_prototype;
5760         }
5761         break;
5762     case 'q':
5763         if (len <= 2) {
5764             if (strEQ(d,"q"))                   return KEY_q;
5765             if (strEQ(d,"qr"))                  return KEY_qr;
5766             if (strEQ(d,"qq"))                  return KEY_qq;
5767             if (strEQ(d,"qw"))                  return KEY_qw;
5768             if (strEQ(d,"qx"))                  return KEY_qx;
5769         }
5770         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
5771         break;
5772     case 'r':
5773         switch (len) {
5774         case 3:
5775             if (strEQ(d,"ref"))                 return -KEY_ref;
5776             break;
5777         case 4:
5778             if (strEQ(d,"read"))                return -KEY_read;
5779             if (strEQ(d,"rand"))                return -KEY_rand;
5780             if (strEQ(d,"recv"))                return -KEY_recv;
5781             if (strEQ(d,"redo"))                return KEY_redo;
5782             break;
5783         case 5:
5784             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
5785             if (strEQ(d,"reset"))               return -KEY_reset;
5786             break;
5787         case 6:
5788             if (strEQ(d,"return"))              return KEY_return;
5789             if (strEQ(d,"rename"))              return -KEY_rename;
5790             if (strEQ(d,"rindex"))              return -KEY_rindex;
5791             break;
5792         case 7:
5793             if (strEQ(d,"require"))             return KEY_require;
5794             if (strEQ(d,"reverse"))             return -KEY_reverse;
5795             if (strEQ(d,"readdir"))             return -KEY_readdir;
5796             break;
5797         case 8:
5798             if (strEQ(d,"readlink"))            return -KEY_readlink;
5799             if (strEQ(d,"readline"))            return -KEY_readline;
5800             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
5801             break;
5802         case 9:
5803             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
5804             break;
5805         }
5806         break;
5807     case 's':
5808         switch (d[1]) {
5809         case 0:                                 return KEY_s;
5810         case 'c':
5811             if (strEQ(d,"scalar"))              return KEY_scalar;
5812             break;
5813         case 'e':
5814             switch (len) {
5815             case 4:
5816                 if (strEQ(d,"seek"))            return -KEY_seek;
5817                 if (strEQ(d,"send"))            return -KEY_send;
5818                 break;
5819             case 5:
5820                 if (strEQ(d,"semop"))           return -KEY_semop;
5821                 break;
5822             case 6:
5823                 if (strEQ(d,"select"))          return -KEY_select;
5824                 if (strEQ(d,"semctl"))          return -KEY_semctl;
5825                 if (strEQ(d,"semget"))          return -KEY_semget;
5826                 break;
5827             case 7:
5828                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
5829                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
5830                 break;
5831             case 8:
5832                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
5833                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
5834                 break;
5835             case 9:
5836                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
5837                 break;
5838             case 10:
5839                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
5840                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
5841                 if (strEQ(d,"setservent"))      return -KEY_setservent;
5842                 break;
5843             case 11:
5844                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
5845                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
5846                 break;
5847             }
5848             break;
5849         case 'h':
5850             switch (len) {
5851             case 5:
5852                if (strEQ(d,"shift"))           return -KEY_shift;
5853                 break;
5854             case 6:
5855                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
5856                 if (strEQ(d,"shmget"))          return -KEY_shmget;
5857                 break;
5858             case 7:
5859                 if (strEQ(d,"shmread"))         return -KEY_shmread;
5860                 break;
5861             case 8:
5862                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
5863                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
5864                 break;
5865             }
5866             break;
5867         case 'i':
5868             if (strEQ(d,"sin"))                 return -KEY_sin;
5869             break;
5870         case 'l':
5871             if (strEQ(d,"sleep"))               return -KEY_sleep;
5872             break;
5873         case 'o':
5874             if (strEQ(d,"sort"))                return KEY_sort;
5875             if (strEQ(d,"socket"))              return -KEY_socket;
5876             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
5877             break;
5878         case 'p':
5879             if (strEQ(d,"split"))               return KEY_split;
5880             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
5881            if (strEQ(d,"splice"))              return -KEY_splice;
5882             break;
5883         case 'q':
5884             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
5885             break;
5886         case 'r':
5887             if (strEQ(d,"srand"))               return -KEY_srand;
5888             break;
5889         case 't':
5890             if (strEQ(d,"stat"))                return -KEY_stat;
5891             if (strEQ(d,"study"))               return KEY_study;
5892             break;
5893         case 'u':
5894             if (strEQ(d,"substr"))              return -KEY_substr;
5895             if (strEQ(d,"sub"))                 return KEY_sub;
5896             break;
5897         case 'y':
5898             switch (len) {
5899             case 6:
5900                 if (strEQ(d,"system"))          return -KEY_system;
5901                 break;
5902             case 7:
5903                 if (strEQ(d,"symlink"))         return -KEY_symlink;
5904                 if (strEQ(d,"syscall"))         return -KEY_syscall;
5905                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
5906                 if (strEQ(d,"sysread"))         return -KEY_sysread;
5907                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
5908                 break;
5909             case 8:
5910                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
5911                 break;
5912             }
5913             break;
5914         }
5915         break;
5916     case 't':
5917         switch (len) {
5918         case 2:
5919             if (strEQ(d,"tr"))                  return KEY_tr;
5920             break;
5921         case 3:
5922             if (strEQ(d,"tie"))                 return KEY_tie;
5923             break;
5924         case 4:
5925             if (strEQ(d,"tell"))                return -KEY_tell;
5926             if (strEQ(d,"tied"))                return KEY_tied;
5927             if (strEQ(d,"time"))                return -KEY_time;
5928             break;
5929         case 5:
5930             if (strEQ(d,"times"))               return -KEY_times;
5931             break;
5932         case 7:
5933             if (strEQ(d,"telldir"))             return -KEY_telldir;
5934             break;
5935         case 8:
5936             if (strEQ(d,"truncate"))            return -KEY_truncate;
5937             break;
5938         }
5939         break;
5940     case 'u':
5941         switch (len) {
5942         case 2:
5943             if (strEQ(d,"uc"))                  return -KEY_uc;
5944             break;
5945         case 3:
5946             if (strEQ(d,"use"))                 return KEY_use;
5947             break;
5948         case 5:
5949             if (strEQ(d,"undef"))               return KEY_undef;
5950             if (strEQ(d,"until"))               return KEY_until;
5951             if (strEQ(d,"untie"))               return KEY_untie;
5952             if (strEQ(d,"utime"))               return -KEY_utime;
5953             if (strEQ(d,"umask"))               return -KEY_umask;
5954             break;
5955         case 6:
5956             if (strEQ(d,"unless"))              return KEY_unless;
5957             if (strEQ(d,"unpack"))              return -KEY_unpack;
5958             if (strEQ(d,"unlink"))              return -KEY_unlink;
5959             break;
5960         case 7:
5961            if (strEQ(d,"unshift"))             return -KEY_unshift;
5962             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
5963             break;
5964         }
5965         break;
5966     case 'v':
5967         if (strEQ(d,"values"))                  return -KEY_values;
5968         if (strEQ(d,"vec"))                     return -KEY_vec;
5969         break;
5970     case 'w':
5971         switch (len) {
5972         case 4:
5973             if (strEQ(d,"warn"))                return -KEY_warn;
5974             if (strEQ(d,"wait"))                return -KEY_wait;
5975             break;
5976         case 5:
5977             if (strEQ(d,"while"))               return KEY_while;
5978             if (strEQ(d,"write"))               return -KEY_write;
5979             break;
5980         case 7:
5981             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
5982             break;
5983         case 9:
5984             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
5985             break;
5986         }
5987         break;
5988     case 'x':
5989         if (len == 1)                           return -KEY_x;
5990         if (strEQ(d,"xor"))                     return -KEY_xor;
5991         break;
5992     case 'y':
5993         if (len == 1)                           return KEY_y;
5994         break;
5995     case 'z':
5996         break;
5997     }
5998     return 0;
5999 }
6000
6001 STATIC void
6002 S_checkcomma(pTHX_ register char *s, char *name, char *what)
6003 {
6004     char *w;
6005
6006     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
6007         if (ckWARN(WARN_SYNTAX)) {
6008             int level = 1;
6009             for (w = s+2; *w && level; w++) {
6010                 if (*w == '(')
6011                     ++level;
6012                 else if (*w == ')')
6013                     --level;
6014             }
6015             if (*w)
6016                 for (; *w && isSPACE(*w); w++) ;
6017             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
6018                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6019                             "%s (...) interpreted as function",name);
6020         }
6021     }
6022     while (s < PL_bufend && isSPACE(*s))
6023         s++;
6024     if (*s == '(')
6025         s++;
6026     while (s < PL_bufend && isSPACE(*s))
6027         s++;
6028     if (isIDFIRST_lazy_if(s,UTF)) {
6029         w = s++;
6030         while (isALNUM_lazy_if(s,UTF))
6031             s++;
6032         while (s < PL_bufend && isSPACE(*s))
6033             s++;
6034         if (*s == ',') {
6035             int kw;
6036             *s = '\0';
6037             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
6038             *s = ',';
6039             if (kw)
6040                 return;
6041             Perl_croak(aTHX_ "No comma allowed after %s", what);
6042         }
6043     }
6044 }
6045
6046 /* Either returns sv, or mortalizes sv and returns a new SV*.
6047    Best used as sv=new_constant(..., sv, ...).
6048    If s, pv are NULL, calls subroutine with one argument,
6049    and type is used with error messages only. */
6050
6051 STATIC SV *
6052 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
6053                const char *type)
6054 {
6055     dSP;
6056     HV *table = GvHV(PL_hintgv);                 /* ^H */
6057     SV *res;
6058     SV **cvp;
6059     SV *cv, *typesv;
6060     const char *why1, *why2, *why3;
6061
6062     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
6063         SV *msg;
6064         
6065         why2 = strEQ(key,"charnames")
6066                ? "(possibly a missing \"use charnames ...\")"
6067                : "";
6068         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
6069                             (type ? type: "undef"), why2);
6070
6071         /* This is convoluted and evil ("goto considered harmful")
6072          * but I do not understand the intricacies of all the different
6073          * failure modes of %^H in here.  The goal here is to make
6074          * the most probable error message user-friendly. --jhi */
6075
6076         goto msgdone;
6077
6078     report:
6079         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
6080                             (type ? type: "undef"), why1, why2, why3);
6081     msgdone:
6082         yyerror(SvPVX(msg));
6083         SvREFCNT_dec(msg);
6084         return sv;
6085     }
6086     cvp = hv_fetch(table, key, strlen(key), FALSE);
6087     if (!cvp || !SvOK(*cvp)) {
6088         why1 = "$^H{";
6089         why2 = key;
6090         why3 = "} is not defined";
6091         goto report;
6092     }
6093     sv_2mortal(sv);                     /* Parent created it permanently */
6094     cv = *cvp;
6095     if (!pv && s)
6096         pv = sv_2mortal(newSVpvn(s, len));
6097     if (type && pv)
6098         typesv = sv_2mortal(newSVpv(type, 0));
6099     else
6100         typesv = &PL_sv_undef;
6101
6102     PUSHSTACKi(PERLSI_OVERLOAD);
6103     ENTER ;
6104     SAVETMPS;
6105
6106     PUSHMARK(SP) ;
6107     EXTEND(sp, 3);
6108     if (pv)
6109         PUSHs(pv);
6110     PUSHs(sv);
6111     if (pv)
6112         PUSHs(typesv);
6113     PUTBACK;
6114     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
6115
6116     SPAGAIN ;
6117
6118     /* Check the eval first */
6119     if (!PL_in_eval && SvTRUE(ERRSV)) {
6120         STRLEN n_a;
6121         sv_catpv(ERRSV, "Propagated");
6122         yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
6123         (void)POPs;
6124         res = SvREFCNT_inc(sv);
6125     }
6126     else {
6127         res = POPs;
6128         (void)SvREFCNT_inc(res);
6129     }
6130
6131     PUTBACK ;
6132     FREETMPS ;
6133     LEAVE ;
6134     POPSTACK;
6135
6136     if (!SvOK(res)) {
6137         why1 = "Call to &{$^H{";
6138         why2 = key;
6139         why3 = "}} did not return a defined value";
6140         sv = res;
6141         goto report;
6142     }
6143
6144     return res;
6145 }
6146
6147 STATIC char *
6148 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6149 {
6150     register char *d = dest;
6151     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
6152     for (;;) {
6153         if (d >= e)
6154             Perl_croak(aTHX_ ident_too_long);
6155         if (isALNUM(*s))        /* UTF handled below */
6156             *d++ = *s++;
6157         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6158             *d++ = ':';
6159             *d++ = ':';
6160             s++;
6161         }
6162         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6163             *d++ = *s++;
6164             *d++ = *s++;
6165         }
6166         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6167             char *t = s + UTF8SKIP(s);
6168             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6169                 t += UTF8SKIP(t);
6170             if (d + (t - s) > e)
6171                 Perl_croak(aTHX_ ident_too_long);
6172             Copy(s, d, t - s, char);
6173             d += t - s;
6174             s = t;
6175         }
6176         else {
6177             *d = '\0';
6178             *slp = d - dest;
6179             return s;
6180         }
6181     }
6182 }
6183
6184 STATIC char *
6185 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6186 {
6187     register char *d;
6188     register char *e;
6189     char *bracket = 0;
6190     char funny = *s++;
6191
6192     if (isSPACE(*s))
6193         s = skipspace(s);
6194     d = dest;
6195     e = d + destlen - 3;        /* two-character token, ending NUL */
6196     if (isDIGIT(*s)) {
6197         while (isDIGIT(*s)) {
6198             if (d >= e)
6199                 Perl_croak(aTHX_ ident_too_long);
6200             *d++ = *s++;
6201         }
6202     }
6203     else {
6204         for (;;) {
6205             if (d >= e)
6206                 Perl_croak(aTHX_ ident_too_long);
6207             if (isALNUM(*s))    /* UTF handled below */
6208                 *d++ = *s++;
6209             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6210                 *d++ = ':';
6211                 *d++ = ':';
6212                 s++;
6213             }
6214             else if (*s == ':' && s[1] == ':') {
6215                 *d++ = *s++;
6216                 *d++ = *s++;
6217             }
6218             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6219                 char *t = s + UTF8SKIP(s);
6220                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6221                     t += UTF8SKIP(t);
6222                 if (d + (t - s) > e)
6223                     Perl_croak(aTHX_ ident_too_long);
6224                 Copy(s, d, t - s, char);
6225                 d += t - s;
6226                 s = t;
6227             }
6228             else
6229                 break;
6230         }
6231     }
6232     *d = '\0';
6233     d = dest;
6234     if (*d) {
6235         if (PL_lex_state != LEX_NORMAL)
6236             PL_lex_state = LEX_INTERPENDMAYBE;
6237         return s;
6238     }
6239     if (*s == '$' && s[1] &&
6240         (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6241     {
6242         return s;
6243     }
6244     if (*s == '{') {
6245         bracket = s;
6246         s++;
6247     }
6248     else if (ck_uni)
6249         check_uni();
6250     if (s < send)
6251         *d = *s++;
6252     d[1] = '\0';
6253     if (*d == '^' && *s && isCONTROLVAR(*s)) {
6254         *d = toCTRL(*s);
6255         s++;
6256     }
6257     if (bracket) {
6258         if (isSPACE(s[-1])) {
6259             while (s < send) {
6260                 char ch = *s++;
6261                 if (!SPACE_OR_TAB(ch)) {
6262                     *d = ch;
6263                     break;
6264                 }
6265             }
6266         }
6267         if (isIDFIRST_lazy_if(d,UTF)) {
6268             d++;
6269             if (UTF) {
6270                 e = s;
6271                 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6272                     e += UTF8SKIP(e);
6273                     while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6274                         e += UTF8SKIP(e);
6275                 }
6276                 Copy(s, d, e - s, char);
6277                 d += e - s;
6278                 s = e;
6279             }
6280             else {
6281                 while ((isALNUM(*s) || *s == ':') && d < e)
6282                     *d++ = *s++;
6283                 if (d >= e)
6284                     Perl_croak(aTHX_ ident_too_long);
6285             }
6286             *d = '\0';
6287             while (s < send && SPACE_OR_TAB(*s)) s++;
6288             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6289                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6290                     const char *brack = *s == '[' ? "[...]" : "{...}";
6291                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6292                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6293                         funny, dest, brack, funny, dest, brack);
6294                 }
6295                 bracket++;
6296                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6297                 return s;
6298             }
6299         }
6300         /* Handle extended ${^Foo} variables
6301          * 1999-02-27 mjd-perl-patch@plover.com */
6302         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6303                  && isALNUM(*s))
6304         {
6305             d++;
6306             while (isALNUM(*s) && d < e) {
6307                 *d++ = *s++;
6308             }
6309             if (d >= e)
6310                 Perl_croak(aTHX_ ident_too_long);
6311             *d = '\0';
6312         }
6313         if (*s == '}') {
6314             s++;
6315             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
6316                 PL_lex_state = LEX_INTERPEND;
6317                 PL_expect = XREF;
6318             }
6319             if (funny == '#')
6320                 funny = '@';
6321             if (PL_lex_state == LEX_NORMAL) {
6322                 if (ckWARN(WARN_AMBIGUOUS) &&
6323                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6324                 {
6325                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6326                         "Ambiguous use of %c{%s} resolved to %c%s",
6327                         funny, dest, funny, dest);
6328                 }
6329             }
6330         }
6331         else {
6332             s = bracket;                /* let the parser handle it */
6333             *dest = '\0';
6334         }
6335     }
6336     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6337         PL_lex_state = LEX_INTERPEND;
6338     return s;
6339 }
6340
6341 void
6342 Perl_pmflag(pTHX_ U32* pmfl, int ch)
6343 {
6344     if (ch == 'i')
6345         *pmfl |= PMf_FOLD;
6346     else if (ch == 'g')
6347         *pmfl |= PMf_GLOBAL;
6348     else if (ch == 'c')
6349         *pmfl |= PMf_CONTINUE;
6350     else if (ch == 'o')
6351         *pmfl |= PMf_KEEP;
6352     else if (ch == 'm')
6353         *pmfl |= PMf_MULTILINE;
6354     else if (ch == 's')
6355         *pmfl |= PMf_SINGLELINE;
6356     else if (ch == 'x')
6357         *pmfl |= PMf_EXTENDED;
6358 }
6359
6360 STATIC char *
6361 S_scan_pat(pTHX_ char *start, I32 type)
6362 {
6363     PMOP *pm;
6364     char *s;
6365
6366     s = scan_str(start,FALSE,FALSE);
6367     if (!s)
6368         Perl_croak(aTHX_ "Search pattern not terminated");
6369
6370     pm = (PMOP*)newPMOP(type, 0);
6371     if (PL_multi_open == '?')
6372         pm->op_pmflags |= PMf_ONCE;
6373     if(type == OP_QR) {
6374         while (*s && strchr("iomsx", *s))
6375             pmflag(&pm->op_pmflags,*s++);
6376     }
6377     else {
6378         while (*s && strchr("iogcmsx", *s))
6379             pmflag(&pm->op_pmflags,*s++);
6380     }
6381     /* issue a warning if /c is specified,but /g is not */
6382     if (ckWARN(WARN_REGEXP) && 
6383         (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
6384     {
6385         Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
6386     }
6387
6388     pm->op_pmpermflags = pm->op_pmflags;
6389
6390     PL_lex_op = (OP*)pm;
6391     yylval.ival = OP_MATCH;
6392     return s;
6393 }
6394
6395 STATIC char *
6396 S_scan_subst(pTHX_ char *start)
6397 {
6398     register char *s;
6399     register PMOP *pm;
6400     I32 first_start;
6401     I32 es = 0;
6402
6403     yylval.ival = OP_NULL;
6404
6405     s = scan_str(start,FALSE,FALSE);
6406
6407     if (!s)
6408         Perl_croak(aTHX_ "Substitution pattern not terminated");
6409
6410     if (s[-1] == PL_multi_open)
6411         s--;
6412
6413     first_start = PL_multi_start;
6414     s = scan_str(s,FALSE,FALSE);
6415     if (!s) {
6416         if (PL_lex_stuff) {
6417             SvREFCNT_dec(PL_lex_stuff);
6418             PL_lex_stuff = Nullsv;
6419         }
6420         Perl_croak(aTHX_ "Substitution replacement not terminated");
6421     }
6422     PL_multi_start = first_start;       /* so whole substitution is taken together */
6423
6424     pm = (PMOP*)newPMOP(OP_SUBST, 0);
6425     while (*s) {
6426         if (*s == 'e') {
6427             s++;
6428             es++;
6429         }
6430         else if (strchr("iogcmsx", *s))
6431             pmflag(&pm->op_pmflags,*s++);
6432         else
6433             break;
6434     }
6435
6436     /* /c is not meaningful with s/// */
6437     if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
6438     {
6439         Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
6440     }
6441
6442     if (es) {
6443         SV *repl;
6444         PL_sublex_info.super_bufptr = s;
6445         PL_sublex_info.super_bufend = PL_bufend;
6446         PL_multi_end = 0;
6447         pm->op_pmflags |= PMf_EVAL;
6448         repl = newSVpvn("",0);
6449         while (es-- > 0)
6450             sv_catpv(repl, es ? "eval " : "do ");
6451         sv_catpvn(repl, "{ ", 2);
6452         sv_catsv(repl, PL_lex_repl);
6453         sv_catpvn(repl, " };", 2);
6454         SvEVALED_on(repl);
6455         SvREFCNT_dec(PL_lex_repl);
6456         PL_lex_repl = repl;
6457     }
6458
6459     pm->op_pmpermflags = pm->op_pmflags;
6460     PL_lex_op = (OP*)pm;
6461     yylval.ival = OP_SUBST;
6462     return s;
6463 }
6464
6465 STATIC char *
6466 S_scan_trans(pTHX_ char *start)
6467 {
6468     register char* s;
6469     OP *o;
6470     short *tbl;
6471     I32 squash;
6472     I32 del;
6473     I32 complement;
6474
6475     yylval.ival = OP_NULL;
6476
6477     s = scan_str(start,FALSE,FALSE);
6478     if (!s)
6479         Perl_croak(aTHX_ "Transliteration pattern not terminated");
6480     if (s[-1] == PL_multi_open)
6481         s--;
6482
6483     s = scan_str(s,FALSE,FALSE);
6484     if (!s) {
6485         if (PL_lex_stuff) {
6486             SvREFCNT_dec(PL_lex_stuff);
6487             PL_lex_stuff = Nullsv;
6488         }
6489         Perl_croak(aTHX_ "Transliteration replacement not terminated");
6490     }
6491
6492     complement = del = squash = 0;
6493     while (strchr("cds", *s)) {
6494         if (*s == 'c')
6495             complement = OPpTRANS_COMPLEMENT;
6496         else if (*s == 'd')
6497             del = OPpTRANS_DELETE;
6498         else if (*s == 's')
6499             squash = OPpTRANS_SQUASH;
6500         s++;
6501     }
6502
6503     New(803, tbl, complement&&!del?258:256, short);
6504     o = newPVOP(OP_TRANS, 0, (char*)tbl);
6505     o->op_private &= ~OPpTRANS_ALL;
6506     o->op_private |= del|squash|complement|
6507       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6508       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
6509
6510     PL_lex_op = o;
6511     yylval.ival = OP_TRANS;
6512     return s;
6513 }
6514
6515 STATIC char *
6516 S_scan_heredoc(pTHX_ register char *s)
6517 {
6518     SV *herewas;
6519     I32 op_type = OP_SCALAR;
6520     I32 len;
6521     SV *tmpstr;
6522     char term;
6523     register char *d;
6524     register char *e;
6525     char *peek;
6526     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6527
6528     s += 2;
6529     d = PL_tokenbuf;
6530     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6531     if (!outer)
6532         *d++ = '\n';
6533     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6534     if (*peek && strchr("`'\"",*peek)) {
6535         s = peek;
6536         term = *s++;
6537         s = delimcpy(d, e, s, PL_bufend, term, &len);
6538         d += len;
6539         if (s < PL_bufend)
6540             s++;
6541     }
6542     else {
6543         if (*s == '\\')
6544             s++, term = '\'';
6545         else
6546             term = '"';
6547         if (!isALNUM_lazy_if(s,UTF))
6548             deprecate_old("bare << to mean <<\"\"");
6549         for (; isALNUM_lazy_if(s,UTF); s++) {
6550             if (d < e)
6551                 *d++ = *s;
6552         }
6553     }
6554     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6555         Perl_croak(aTHX_ "Delimiter for here document is too long");
6556     *d++ = '\n';
6557     *d = '\0';
6558     len = d - PL_tokenbuf;
6559 #ifndef PERL_STRICT_CR
6560     d = strchr(s, '\r');
6561     if (d) {
6562         char *olds = s;
6563         s = d;
6564         while (s < PL_bufend) {
6565             if (*s == '\r') {
6566                 *d++ = '\n';
6567                 if (*++s == '\n')
6568                     s++;
6569             }
6570             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
6571                 *d++ = *s++;
6572                 s++;
6573             }
6574             else
6575                 *d++ = *s++;
6576         }
6577         *d = '\0';
6578         PL_bufend = d;
6579         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6580         s = olds;
6581     }
6582 #endif
6583     d = "\n";
6584     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6585         herewas = newSVpvn(s,PL_bufend-s);
6586     else
6587         s--, herewas = newSVpvn(s,d-s);
6588     s += SvCUR(herewas);
6589
6590     tmpstr = NEWSV(87,79);
6591     sv_upgrade(tmpstr, SVt_PVIV);
6592     if (term == '\'') {
6593         op_type = OP_CONST;
6594         SvIVX(tmpstr) = -1;
6595     }
6596     else if (term == '`') {
6597         op_type = OP_BACKTICK;
6598         SvIVX(tmpstr) = '\\';
6599     }
6600
6601     CLINE;
6602     PL_multi_start = CopLINE(PL_curcop);
6603     PL_multi_open = PL_multi_close = '<';
6604     term = *PL_tokenbuf;
6605     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6606         char *bufptr = PL_sublex_info.super_bufptr;
6607         char *bufend = PL_sublex_info.super_bufend;
6608         char *olds = s - SvCUR(herewas);
6609         s = strchr(bufptr, '\n');
6610         if (!s)
6611             s = bufend;
6612         d = s;
6613         while (s < bufend &&
6614           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6615             if (*s++ == '\n')
6616                 CopLINE_inc(PL_curcop);
6617         }
6618         if (s >= bufend) {
6619             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6620             missingterm(PL_tokenbuf);
6621         }
6622         sv_setpvn(herewas,bufptr,d-bufptr+1);
6623         sv_setpvn(tmpstr,d+1,s-d);
6624         s += len - 1;
6625         sv_catpvn(herewas,s,bufend-s);
6626         (void)strcpy(bufptr,SvPVX(herewas));
6627
6628         s = olds;
6629         goto retval;
6630     }
6631     else if (!outer) {
6632         d = s;
6633         while (s < PL_bufend &&
6634           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6635             if (*s++ == '\n')
6636                 CopLINE_inc(PL_curcop);
6637         }
6638         if (s >= PL_bufend) {
6639             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6640             missingterm(PL_tokenbuf);
6641         }
6642         sv_setpvn(tmpstr,d+1,s-d);
6643         s += len - 1;
6644         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6645
6646         sv_catpvn(herewas,s,PL_bufend-s);
6647         sv_setsv(PL_linestr,herewas);
6648         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6649         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6650         PL_last_lop = PL_last_uni = Nullch;
6651     }
6652     else
6653         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
6654     while (s >= PL_bufend) {    /* multiple line string? */
6655         if (!outer ||
6656          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6657             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6658             missingterm(PL_tokenbuf);
6659         }
6660         CopLINE_inc(PL_curcop);
6661         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6662         PL_last_lop = PL_last_uni = Nullch;
6663 #ifndef PERL_STRICT_CR
6664         if (PL_bufend - PL_linestart >= 2) {
6665             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6666                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6667             {
6668                 PL_bufend[-2] = '\n';
6669                 PL_bufend--;
6670                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6671             }
6672             else if (PL_bufend[-1] == '\r')
6673                 PL_bufend[-1] = '\n';
6674         }
6675         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6676             PL_bufend[-1] = '\n';
6677 #endif
6678         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6679             SV *sv = NEWSV(88,0);
6680
6681             sv_upgrade(sv, SVt_PVMG);
6682             sv_setsv(sv,PL_linestr);
6683             (void)SvIOK_on(sv);
6684             SvIVX(sv) = 0;
6685             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6686         }
6687         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6688             s = PL_bufend - 1;
6689             *s = ' ';
6690             sv_catsv(PL_linestr,herewas);
6691             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6692         }
6693         else {
6694             s = PL_bufend;
6695             sv_catsv(tmpstr,PL_linestr);
6696         }
6697     }
6698     s++;
6699 retval:
6700     PL_multi_end = CopLINE(PL_curcop);
6701     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6702         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6703         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6704     }
6705     SvREFCNT_dec(herewas);
6706     if (!IN_BYTES) {
6707         if (UTF && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6708             SvUTF8_on(tmpstr);
6709         else if (PL_encoding)
6710             sv_recode_to_utf8(tmpstr, PL_encoding);
6711     }
6712     PL_lex_stuff = tmpstr;
6713     yylval.ival = op_type;
6714     return s;
6715 }
6716
6717 /* scan_inputsymbol
6718    takes: current position in input buffer
6719    returns: new position in input buffer
6720    side-effects: yylval and lex_op are set.
6721
6722    This code handles:
6723
6724    <>           read from ARGV
6725    <FH>         read from filehandle
6726    <pkg::FH>    read from package qualified filehandle
6727    <pkg'FH>     read from package qualified filehandle
6728    <$fh>        read from filehandle in $fh
6729    <*.h>        filename glob
6730
6731 */
6732
6733 STATIC char *
6734 S_scan_inputsymbol(pTHX_ char *start)
6735 {
6736     register char *s = start;           /* current position in buffer */
6737     register char *d;
6738     register char *e;
6739     char *end;
6740     I32 len;
6741
6742     d = PL_tokenbuf;                    /* start of temp holding space */
6743     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
6744     end = strchr(s, '\n');
6745     if (!end)
6746         end = PL_bufend;
6747     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
6748
6749     /* die if we didn't have space for the contents of the <>,
6750        or if it didn't end, or if we see a newline
6751     */
6752
6753     if (len >= sizeof PL_tokenbuf)
6754         Perl_croak(aTHX_ "Excessively long <> operator");
6755     if (s >= end)
6756         Perl_croak(aTHX_ "Unterminated <> operator");
6757
6758     s++;
6759
6760     /* check for <$fh>
6761        Remember, only scalar variables are interpreted as filehandles by
6762        this code.  Anything more complex (e.g., <$fh{$num}>) will be
6763        treated as a glob() call.
6764        This code makes use of the fact that except for the $ at the front,
6765        a scalar variable and a filehandle look the same.
6766     */
6767     if (*d == '$' && d[1]) d++;
6768
6769     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6770     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6771         d++;
6772
6773     /* If we've tried to read what we allow filehandles to look like, and
6774        there's still text left, then it must be a glob() and not a getline.
6775        Use scan_str to pull out the stuff between the <> and treat it
6776        as nothing more than a string.
6777     */
6778
6779     if (d - PL_tokenbuf != len) {
6780         yylval.ival = OP_GLOB;
6781         set_csh();
6782         s = scan_str(start,FALSE,FALSE);
6783         if (!s)
6784            Perl_croak(aTHX_ "Glob not terminated");
6785         return s;
6786     }
6787     else {
6788         bool readline_overriden = FALSE;
6789         GV *gv_readline = Nullgv;
6790         GV **gvp;
6791         /* we're in a filehandle read situation */
6792         d = PL_tokenbuf;
6793
6794         /* turn <> into <ARGV> */
6795         if (!len)
6796             (void)strcpy(d,"ARGV");
6797
6798         /* Check whether readline() is overriden */
6799         if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
6800                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
6801                 ||
6802                 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
6803                 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
6804                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
6805             readline_overriden = TRUE;
6806
6807         /* if <$fh>, create the ops to turn the variable into a
6808            filehandle
6809         */
6810         if (*d == '$') {
6811             I32 tmp;
6812
6813             /* try to find it in the pad for this block, otherwise find
6814                add symbol table ops
6815             */
6816             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6817                 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
6818                     SV *sym = sv_2mortal(
6819                             newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)),0));
6820                     sv_catpvn(sym, "::", 2);
6821                     sv_catpv(sym, d+1);
6822                     d = SvPVX(sym);
6823                     goto intro_sym;
6824                 }
6825                 else {
6826                     OP *o = newOP(OP_PADSV, 0);
6827                     o->op_targ = tmp;
6828                     PL_lex_op = readline_overriden
6829                         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6830                                 append_elem(OP_LIST, o,
6831                                     newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
6832                         : (OP*)newUNOP(OP_READLINE, 0, o);
6833                 }
6834             }
6835             else {
6836                 GV *gv;
6837                 ++d;
6838 intro_sym:
6839                 gv = gv_fetchpv(d,
6840                                 (PL_in_eval
6841                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
6842                                  : GV_ADDMULTI),
6843                                 SVt_PV);
6844                 PL_lex_op = readline_overriden
6845                     ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6846                             append_elem(OP_LIST,
6847                                 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
6848                                 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6849                     : (OP*)newUNOP(OP_READLINE, 0,
6850                             newUNOP(OP_RV2SV, 0,
6851                                 newGVOP(OP_GV, 0, gv)));
6852             }
6853             if (!readline_overriden)
6854                 PL_lex_op->op_flags |= OPf_SPECIAL;
6855             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6856             yylval.ival = OP_NULL;
6857         }
6858
6859         /* If it's none of the above, it must be a literal filehandle
6860            (<Foo::BAR> or <FOO>) so build a simple readline OP */
6861         else {
6862             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6863             PL_lex_op = readline_overriden
6864                 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6865                         append_elem(OP_LIST,
6866                             newGVOP(OP_GV, 0, gv),
6867                             newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6868                 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6869             yylval.ival = OP_NULL;
6870         }
6871     }
6872
6873     return s;
6874 }
6875
6876
6877 /* scan_str
6878    takes: start position in buffer
6879           keep_quoted preserve \ on the embedded delimiter(s)
6880           keep_delims preserve the delimiters around the string
6881    returns: position to continue reading from buffer
6882    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6883         updates the read buffer.
6884
6885    This subroutine pulls a string out of the input.  It is called for:
6886         q               single quotes           q(literal text)
6887         '               single quotes           'literal text'
6888         qq              double quotes           qq(interpolate $here please)
6889         "               double quotes           "interpolate $here please"
6890         qx              backticks               qx(/bin/ls -l)
6891         `               backticks               `/bin/ls -l`
6892         qw              quote words             @EXPORT_OK = qw( func() $spam )
6893         m//             regexp match            m/this/
6894         s///            regexp substitute       s/this/that/
6895         tr///           string transliterate    tr/this/that/
6896         y///            string transliterate    y/this/that/
6897         ($*@)           sub prototypes          sub foo ($)
6898         (stuff)         sub attr parameters     sub foo : attr(stuff)
6899         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
6900         
6901    In most of these cases (all but <>, patterns and transliterate)
6902    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
6903    calls scan_str().  s/// makes yylex() call scan_subst() which calls
6904    scan_str().  tr/// and y/// make yylex() call scan_trans() which
6905    calls scan_str().
6906
6907    It skips whitespace before the string starts, and treats the first
6908    character as the delimiter.  If the delimiter is one of ([{< then
6909    the corresponding "close" character )]}> is used as the closing
6910    delimiter.  It allows quoting of delimiters, and if the string has
6911    balanced delimiters ([{<>}]) it allows nesting.
6912
6913    On success, the SV with the resulting string is put into lex_stuff or,
6914    if that is already non-NULL, into lex_repl. The second case occurs only
6915    when parsing the RHS of the special constructs s/// and tr/// (y///).
6916    For convenience, the terminating delimiter character is stuffed into
6917    SvIVX of the SV.
6918 */
6919
6920 STATIC char *
6921 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6922 {
6923     SV *sv;                             /* scalar value: string */
6924     char *tmps;                         /* temp string, used for delimiter matching */
6925     register char *s = start;           /* current position in the buffer */
6926     register char term;                 /* terminating character */
6927     register char *to;                  /* current position in the sv's data */
6928     I32 brackets = 1;                   /* bracket nesting level */
6929     bool has_utf8 = FALSE;              /* is there any utf8 content? */
6930     I32 termcode;                       /* terminating char. code */
6931     U8 termstr[UTF8_MAXLEN];            /* terminating string */
6932     STRLEN termlen;                     /* length of terminating string */
6933     char *last = NULL;                  /* last position for nesting bracket */
6934
6935     /* skip space before the delimiter */
6936     if (isSPACE(*s))
6937         s = skipspace(s);
6938
6939     /* mark where we are, in case we need to report errors */
6940     CLINE;
6941
6942     /* after skipping whitespace, the next character is the terminator */
6943     term = *s;
6944     if (!UTF) {
6945         termcode = termstr[0] = term;
6946         termlen = 1;
6947     }
6948     else {
6949         termcode = utf8_to_uvchr((U8*)s, &termlen);
6950         Copy(s, termstr, termlen, U8);
6951         if (!UTF8_IS_INVARIANT(term))
6952             has_utf8 = TRUE;
6953     }
6954
6955     /* mark where we are */
6956     PL_multi_start = CopLINE(PL_curcop);
6957     PL_multi_open = term;
6958
6959     /* find corresponding closing delimiter */
6960     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6961         termcode = termstr[0] = term = tmps[5];
6962
6963     PL_multi_close = term;
6964
6965     /* create a new SV to hold the contents.  87 is leak category, I'm
6966        assuming.  79 is the SV's initial length.  What a random number. */
6967     sv = NEWSV(87,79);
6968     sv_upgrade(sv, SVt_PVIV);
6969     SvIVX(sv) = termcode;
6970     (void)SvPOK_only(sv);               /* validate pointer */
6971
6972     /* move past delimiter and try to read a complete string */
6973     if (keep_delims)
6974         sv_catpvn(sv, s, termlen);
6975     s += termlen;
6976     for (;;) {
6977         if (PL_encoding && !UTF) {
6978             bool cont = TRUE;
6979
6980             while (cont) {
6981                 int offset = s - SvPVX(PL_linestr);
6982                 bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
6983                                            &offset, (char*)termstr, termlen);
6984                 char *ns = SvPVX(PL_linestr) + offset;
6985                 char *svlast = SvEND(sv) - 1;
6986
6987                 for (; s < ns; s++) {
6988                     if (*s == '\n' && !PL_rsfp)
6989                         CopLINE_inc(PL_curcop);
6990                 }
6991                 if (!found)
6992                     goto read_more_line;
6993                 else {
6994                     /* handle quoted delimiters */
6995                     if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
6996                         char *t;
6997                         for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';)
6998                             t--;
6999                         if ((svlast-1 - t) % 2) {
7000                             if (!keep_quoted) {
7001                                 *(svlast-1) = term;
7002                                 *svlast = '\0';
7003                                 SvCUR_set(sv, SvCUR(sv) - 1);
7004                             }
7005                             continue;
7006                         }
7007                     }
7008                     if (PL_multi_open == PL_multi_close) {
7009                         cont = FALSE;
7010                     }
7011                     else {
7012                         char *t, *w;
7013                         if (!last)
7014                             last = SvPVX(sv);
7015                         for (w = t = last; t < svlast; w++, t++) {
7016                             /* At here, all closes are "was quoted" one,
7017                                so we don't check PL_multi_close. */
7018                             if (*t == '\\') {
7019                                 if (!keep_quoted && *(t+1) == PL_multi_open)
7020                                     t++;
7021                                 else
7022                                     *w++ = *t++;
7023                             }
7024                             else if (*t == PL_multi_open)
7025                                 brackets++;
7026
7027                             *w = *t;
7028                         }
7029                         if (w < t) {
7030                             *w++ = term;
7031                             *w = '\0';
7032                             SvCUR_set(sv, w - SvPVX(sv));
7033                         }
7034                         last = w;
7035                         if (--brackets <= 0)
7036                             cont = FALSE;
7037                     }
7038                 }
7039             }
7040             if (!keep_delims) {
7041                 SvCUR_set(sv, SvCUR(sv) - 1);
7042                 *SvEND(sv) = '\0';
7043             }
7044             break;
7045         }
7046
7047         /* extend sv if need be */
7048         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
7049         /* set 'to' to the next character in the sv's string */
7050         to = SvPVX(sv)+SvCUR(sv);
7051
7052         /* if open delimiter is the close delimiter read unbridle */
7053         if (PL_multi_open == PL_multi_close) {
7054             for (; s < PL_bufend; s++,to++) {
7055                 /* embedded newlines increment the current line number */
7056                 if (*s == '\n' && !PL_rsfp)
7057                     CopLINE_inc(PL_curcop);
7058                 /* handle quoted delimiters */
7059                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
7060                     if (!keep_quoted && s[1] == term)
7061                         s++;
7062                 /* any other quotes are simply copied straight through */
7063                     else
7064                         *to++ = *s++;
7065                 }
7066                 /* terminate when run out of buffer (the for() condition), or
7067                    have found the terminator */
7068                 else if (*s == term) {
7069                     if (termlen == 1)
7070                         break;
7071                     if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
7072                         break;
7073                 }
7074                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7075                     has_utf8 = TRUE;
7076                 *to = *s;
7077             }
7078         }
7079         
7080         /* if the terminator isn't the same as the start character (e.g.,
7081            matched brackets), we have to allow more in the quoting, and
7082            be prepared for nested brackets.
7083         */
7084         else {
7085             /* read until we run out of string, or we find the terminator */
7086             for (; s < PL_bufend; s++,to++) {
7087                 /* embedded newlines increment the line count */
7088                 if (*s == '\n' && !PL_rsfp)
7089                     CopLINE_inc(PL_curcop);
7090                 /* backslashes can escape the open or closing characters */
7091                 if (*s == '\\' && s+1 < PL_bufend) {
7092                     if (!keep_quoted &&
7093                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
7094                         s++;
7095                     else
7096                         *to++ = *s++;
7097                 }
7098                 /* allow nested opens and closes */
7099                 else if (*s == PL_multi_close && --brackets <= 0)
7100                     break;
7101                 else if (*s == PL_multi_open)
7102                     brackets++;
7103                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7104                     has_utf8 = TRUE;
7105                 *to = *s;
7106             }
7107         }
7108         /* terminate the copied string and update the sv's end-of-string */
7109         *to = '\0';
7110         SvCUR_set(sv, to - SvPVX(sv));
7111
7112         /*
7113          * this next chunk reads more into the buffer if we're not done yet
7114          */
7115
7116         if (s < PL_bufend)
7117             break;              /* handle case where we are done yet :-) */
7118
7119 #ifndef PERL_STRICT_CR
7120         if (to - SvPVX(sv) >= 2) {
7121             if ((to[-2] == '\r' && to[-1] == '\n') ||
7122                 (to[-2] == '\n' && to[-1] == '\r'))
7123             {
7124                 to[-2] = '\n';
7125                 to--;
7126                 SvCUR_set(sv, to - SvPVX(sv));
7127             }
7128             else if (to[-1] == '\r')
7129                 to[-1] = '\n';
7130         }
7131         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
7132             to[-1] = '\n';
7133 #endif
7134         
7135      read_more_line:
7136         /* if we're out of file, or a read fails, bail and reset the current
7137            line marker so we can report where the unterminated string began
7138         */
7139         if (!PL_rsfp ||
7140          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
7141             sv_free(sv);
7142             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
7143             return Nullch;
7144         }
7145         /* we read a line, so increment our line counter */
7146         CopLINE_inc(PL_curcop);
7147
7148         /* update debugger info */
7149         if (PERLDB_LINE && PL_curstash != PL_debstash) {
7150             SV *sv = NEWSV(88,0);
7151
7152             sv_upgrade(sv, SVt_PVMG);
7153             sv_setsv(sv,PL_linestr);
7154             (void)SvIOK_on(sv);
7155             SvIVX(sv) = 0;
7156             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
7157         }
7158
7159         /* having changed the buffer, we must update PL_bufend */
7160         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7161         PL_last_lop = PL_last_uni = Nullch;
7162     }
7163
7164     /* at this point, we have successfully read the delimited string */
7165
7166     if (!PL_encoding || UTF) {
7167         if (keep_delims)
7168             sv_catpvn(sv, s, termlen);
7169         s += termlen;
7170     }
7171     if (has_utf8 || PL_encoding)
7172         SvUTF8_on(sv);
7173
7174     PL_multi_end = CopLINE(PL_curcop);
7175
7176     /* if we allocated too much space, give some back */
7177     if (SvCUR(sv) + 5 < SvLEN(sv)) {
7178         SvLEN_set(sv, SvCUR(sv) + 1);
7179         Renew(SvPVX(sv), SvLEN(sv), char);
7180     }
7181
7182     /* decide whether this is the first or second quoted string we've read
7183        for this op
7184     */
7185
7186     if (PL_lex_stuff)
7187         PL_lex_repl = sv;
7188     else
7189         PL_lex_stuff = sv;
7190     return s;
7191 }
7192
7193 /*
7194   scan_num
7195   takes: pointer to position in buffer
7196   returns: pointer to new position in buffer
7197   side-effects: builds ops for the constant in yylval.op
7198
7199   Read a number in any of the formats that Perl accepts:
7200
7201   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
7202   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
7203   0b[01](_?[01])*
7204   0[0-7](_?[0-7])*
7205   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
7206
7207   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
7208   thing it reads.
7209
7210   If it reads a number without a decimal point or an exponent, it will
7211   try converting the number to an integer and see if it can do so
7212   without loss of precision.
7213 */
7214
7215 char *
7216 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
7217 {
7218     register char *s = start;           /* current position in buffer */
7219     register char *d;                   /* destination in temp buffer */
7220     register char *e;                   /* end of temp buffer */
7221     NV nv;                              /* number read, as a double */
7222     SV *sv = Nullsv;                    /* place to put the converted number */
7223     bool floatit;                       /* boolean: int or float? */
7224     char *lastub = 0;                   /* position of last underbar */
7225     static char number_too_long[] = "Number too long";
7226
7227     /* We use the first character to decide what type of number this is */
7228
7229     switch (*s) {
7230     default:
7231       Perl_croak(aTHX_ "panic: scan_num");
7232
7233     /* if it starts with a 0, it could be an octal number, a decimal in
7234        0.13 disguise, or a hexadecimal number, or a binary number. */
7235     case '0':
7236         {
7237           /* variables:
7238              u          holds the "number so far"
7239              shift      the power of 2 of the base
7240                         (hex == 4, octal == 3, binary == 1)
7241              overflowed was the number more than we can hold?
7242
7243              Shift is used when we add a digit.  It also serves as an "are
7244              we in octal/hex/binary?" indicator to disallow hex characters
7245              when in octal mode.
7246            */
7247             NV n = 0.0;
7248             UV u = 0;
7249             I32 shift;
7250             bool overflowed = FALSE;
7251             bool just_zero  = TRUE;     /* just plain 0 or binary number? */
7252             static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
7253             static char* bases[5] = { "", "binary", "", "octal",
7254                                       "hexadecimal" };
7255             static char* Bases[5] = { "", "Binary", "", "Octal",
7256                                       "Hexadecimal" };
7257             static char *maxima[5] = { "",
7258                                        "0b11111111111111111111111111111111",
7259                                        "",
7260                                        "037777777777",
7261                                        "0xffffffff" };
7262             char *base, *Base, *max;
7263
7264             /* check for hex */
7265             if (s[1] == 'x') {
7266                 shift = 4;
7267                 s += 2;
7268                 just_zero = FALSE;
7269             } else if (s[1] == 'b') {
7270                 shift = 1;
7271                 s += 2;
7272                 just_zero = FALSE;
7273             }
7274             /* check for a decimal in disguise */
7275             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
7276                 goto decimal;
7277             /* so it must be octal */
7278             else {
7279                 shift = 3;
7280                 s++;
7281             }
7282
7283             if (*s == '_') {
7284                if (ckWARN(WARN_SYNTAX))
7285                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7286                                "Misplaced _ in number");
7287                lastub = s++;
7288             }
7289
7290             base = bases[shift];
7291             Base = Bases[shift];
7292             max  = maxima[shift];
7293
7294             /* read the rest of the number */
7295             for (;;) {
7296                 /* x is used in the overflow test,
7297                    b is the digit we're adding on. */
7298                 UV x, b;
7299
7300                 switch (*s) {
7301
7302                 /* if we don't mention it, we're done */
7303                 default:
7304                     goto out;
7305
7306                 /* _ are ignored -- but warned about if consecutive */
7307                 case '_':
7308                     if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7309                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7310                                     "Misplaced _ in number");
7311                     lastub = s++;
7312                     break;
7313
7314                 /* 8 and 9 are not octal */
7315                 case '8': case '9':
7316                     if (shift == 3)
7317                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7318                     /* FALL THROUGH */
7319
7320                 /* octal digits */
7321                 case '2': case '3': case '4':
7322                 case '5': case '6': case '7':
7323                     if (shift == 1)
7324                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7325                     /* FALL THROUGH */
7326
7327                 case '0': case '1':
7328                     b = *s++ & 15;              /* ASCII digit -> value of digit */
7329                     goto digit;
7330
7331                 /* hex digits */
7332                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7333                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7334                     /* make sure they said 0x */
7335                     if (shift != 4)
7336                         goto out;
7337                     b = (*s++ & 7) + 9;
7338
7339                     /* Prepare to put the digit we have onto the end
7340                        of the number so far.  We check for overflows.
7341                     */
7342
7343                   digit:
7344                     just_zero = FALSE;
7345                     if (!overflowed) {
7346                         x = u << shift; /* make room for the digit */
7347
7348                         if ((x >> shift) != u
7349                             && !(PL_hints & HINT_NEW_BINARY)) {
7350                             overflowed = TRUE;
7351                             n = (NV) u;
7352                             if (ckWARN_d(WARN_OVERFLOW))
7353                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
7354                                             "Integer overflow in %s number",
7355                                             base);
7356                         } else
7357                             u = x | b;          /* add the digit to the end */
7358                     }
7359                     if (overflowed) {
7360                         n *= nvshift[shift];
7361                         /* If an NV has not enough bits in its
7362                          * mantissa to represent an UV this summing of
7363                          * small low-order numbers is a waste of time
7364                          * (because the NV cannot preserve the
7365                          * low-order bits anyway): we could just
7366                          * remember when did we overflow and in the
7367                          * end just multiply n by the right
7368                          * amount. */
7369                         n += (NV) b;
7370                     }
7371                     break;
7372                 }
7373             }
7374
7375           /* if we get here, we had success: make a scalar value from
7376              the number.
7377           */
7378           out:
7379
7380             /* final misplaced underbar check */
7381             if (s[-1] == '_') {
7382                 if (ckWARN(WARN_SYNTAX))
7383                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7384             }
7385
7386             sv = NEWSV(92,0);
7387             if (overflowed) {
7388                 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7389                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7390                                 "%s number > %s non-portable",
7391                                 Base, max);
7392                 sv_setnv(sv, n);
7393             }
7394             else {
7395 #if UVSIZE > 4
7396                 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7397                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7398                                 "%s number > %s non-portable",
7399                                 Base, max);
7400 #endif
7401                 sv_setuv(sv, u);
7402             }
7403             if (just_zero && (PL_hints & HINT_NEW_INTEGER))
7404                 sv = new_constant(start, s - start, "integer", 
7405                                   sv, Nullsv, NULL);
7406             else if (PL_hints & HINT_NEW_BINARY)
7407                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7408         }
7409         break;
7410
7411     /*
7412       handle decimal numbers.
7413       we're also sent here when we read a 0 as the first digit
7414     */
7415     case '1': case '2': case '3': case '4': case '5':
7416     case '6': case '7': case '8': case '9': case '.':
7417       decimal:
7418         d = PL_tokenbuf;
7419         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7420         floatit = FALSE;
7421
7422         /* read next group of digits and _ and copy into d */
7423         while (isDIGIT(*s) || *s == '_') {
7424             /* skip underscores, checking for misplaced ones
7425                if -w is on
7426             */
7427             if (*s == '_') {
7428                 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7429                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7430                                 "Misplaced _ in number");
7431                 lastub = s++;
7432             }
7433             else {
7434                 /* check for end of fixed-length buffer */
7435                 if (d >= e)
7436                     Perl_croak(aTHX_ number_too_long);
7437                 /* if we're ok, copy the character */
7438                 *d++ = *s++;
7439             }
7440         }
7441
7442         /* final misplaced underbar check */
7443         if (lastub && s == lastub + 1) {
7444             if (ckWARN(WARN_SYNTAX))
7445                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7446         }
7447
7448         /* read a decimal portion if there is one.  avoid
7449            3..5 being interpreted as the number 3. followed
7450            by .5
7451         */
7452         if (*s == '.' && s[1] != '.') {
7453             floatit = TRUE;
7454             *d++ = *s++;
7455
7456             if (*s == '_') {
7457                 if (ckWARN(WARN_SYNTAX))
7458                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7459                                 "Misplaced _ in number");
7460                 lastub = s;
7461             }
7462
7463             /* copy, ignoring underbars, until we run out of digits.
7464             */
7465             for (; isDIGIT(*s) || *s == '_'; s++) {
7466                 /* fixed length buffer check */
7467                 if (d >= e)
7468                     Perl_croak(aTHX_ number_too_long);
7469                 if (*s == '_') {
7470                    if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7471                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7472                                    "Misplaced _ in number");
7473                    lastub = s;
7474                 }
7475                 else
7476                     *d++ = *s;
7477             }
7478             /* fractional part ending in underbar? */
7479             if (s[-1] == '_') {
7480                 if (ckWARN(WARN_SYNTAX))
7481                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7482                                 "Misplaced _ in number");
7483             }
7484             if (*s == '.' && isDIGIT(s[1])) {
7485                 /* oops, it's really a v-string, but without the "v" */
7486                 s = start;
7487                 goto vstring;
7488             }
7489         }
7490
7491         /* read exponent part, if present */
7492         if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7493             floatit = TRUE;
7494             s++;
7495
7496             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7497             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
7498
7499             /* stray preinitial _ */
7500             if (*s == '_') {
7501                 if (ckWARN(WARN_SYNTAX))
7502                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7503                                 "Misplaced _ in number");
7504                 lastub = s++;
7505             }
7506
7507             /* allow positive or negative exponent */
7508             if (*s == '+' || *s == '-')
7509                 *d++ = *s++;
7510
7511             /* stray initial _ */
7512             if (*s == '_') {
7513                 if (ckWARN(WARN_SYNTAX))
7514                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7515                                 "Misplaced _ in number");
7516                 lastub = s++;
7517             }
7518
7519             /* read digits of exponent */
7520             while (isDIGIT(*s) || *s == '_') {
7521                 if (isDIGIT(*s)) {
7522                     if (d >= e)
7523                         Perl_croak(aTHX_ number_too_long);
7524                     *d++ = *s++;
7525                 }
7526                 else {
7527                    if (ckWARN(WARN_SYNTAX) &&
7528                        ((lastub && s == lastub + 1) ||
7529                         (!isDIGIT(s[1]) && s[1] != '_')))
7530                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7531                                    "Misplaced _ in number");
7532                    lastub = s++;
7533                 }
7534             }
7535         }
7536
7537
7538         /* make an sv from the string */
7539         sv = NEWSV(92,0);
7540
7541         /*
7542            We try to do an integer conversion first if no characters
7543            indicating "float" have been found.
7544          */
7545
7546         if (!floatit) {
7547             UV uv;
7548             int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7549
7550             if (flags == IS_NUMBER_IN_UV) {
7551               if (uv <= IV_MAX)
7552                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7553               else
7554                 sv_setuv(sv, uv);
7555             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7556               if (uv <= (UV) IV_MIN)
7557                 sv_setiv(sv, -(IV)uv);
7558               else
7559                 floatit = TRUE;
7560             } else
7561               floatit = TRUE;
7562         }
7563         if (floatit) {
7564             /* terminate the string */
7565             *d = '\0';
7566             nv = Atof(PL_tokenbuf);
7567             sv_setnv(sv, nv);
7568         }
7569
7570         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7571                        (PL_hints & HINT_NEW_INTEGER) )
7572             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7573                               (floatit ? "float" : "integer"),
7574                               sv, Nullsv, NULL);
7575         break;
7576
7577     /* if it starts with a v, it could be a v-string */
7578     case 'v':
7579 vstring:
7580                 sv = NEWSV(92,5); /* preallocate storage space */
7581                 s = scan_vstring(s,sv);
7582         break;
7583     }
7584
7585     /* make the op for the constant and return */
7586
7587     if (sv)
7588         lvalp->opval = newSVOP(OP_CONST, 0, sv);
7589     else
7590         lvalp->opval = Nullop;
7591
7592     return s;
7593 }
7594
7595 STATIC char *
7596 S_scan_formline(pTHX_ register char *s)
7597 {
7598     register char *eol;
7599     register char *t;
7600     SV *stuff = newSVpvn("",0);
7601     bool needargs = FALSE;
7602     bool eofmt = FALSE;
7603
7604     while (!needargs) {
7605         if (*s == '.') {
7606             /*SUPPRESS 530*/
7607 #ifdef PERL_STRICT_CR
7608             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7609 #else
7610             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7611 #endif
7612             if (*t == '\n' || t == PL_bufend) {
7613                 eofmt = TRUE;
7614                 break;
7615             }
7616         }
7617         if (PL_in_eval && !PL_rsfp) {
7618             eol = memchr(s,'\n',PL_bufend-s);
7619             if (!eol++)
7620                 eol = PL_bufend;
7621         }
7622         else
7623             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7624         if (*s != '#') {
7625             for (t = s; t < eol; t++) {
7626                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7627                     needargs = FALSE;
7628                     goto enough;        /* ~~ must be first line in formline */
7629                 }
7630                 if (*t == '@' || *t == '^')
7631                     needargs = TRUE;
7632             }
7633             if (eol > s) {
7634                 sv_catpvn(stuff, s, eol-s);
7635 #ifndef PERL_STRICT_CR
7636                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7637                     char *end = SvPVX(stuff) + SvCUR(stuff);
7638                     end[-2] = '\n';
7639                     end[-1] = '\0';
7640                     SvCUR(stuff)--;
7641                 }
7642 #endif
7643             }
7644             else
7645               break;
7646         }
7647         s = eol;
7648         if (PL_rsfp) {
7649             s = filter_gets(PL_linestr, PL_rsfp, 0);
7650             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7651             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7652             PL_last_lop = PL_last_uni = Nullch;
7653             if (!s) {
7654                 s = PL_bufptr;
7655                 break;
7656             }
7657         }
7658         incline(s);
7659     }
7660   enough:
7661     if (SvCUR(stuff)) {
7662         PL_expect = XTERM;
7663         if (needargs) {
7664             PL_lex_state = LEX_NORMAL;
7665             PL_nextval[PL_nexttoke].ival = 0;
7666             force_next(',');
7667         }
7668         else
7669             PL_lex_state = LEX_FORMLINE;
7670         if (!IN_BYTES) {
7671             if (UTF && is_utf8_string((U8*)SvPVX(stuff), SvCUR(stuff)))
7672                 SvUTF8_on(stuff);
7673             else if (PL_encoding)
7674                 sv_recode_to_utf8(stuff, PL_encoding);
7675         }
7676         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7677         force_next(THING);
7678         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7679         force_next(LSTOP);
7680     }
7681     else {
7682         SvREFCNT_dec(stuff);
7683         if (eofmt)
7684             PL_lex_formbrack = 0;
7685         PL_bufptr = s;
7686     }
7687     return s;
7688 }
7689
7690 STATIC void
7691 S_set_csh(pTHX)
7692 {
7693 #ifdef CSH
7694     if (!PL_cshlen)
7695         PL_cshlen = strlen(PL_cshname);
7696 #endif
7697 }
7698
7699 I32
7700 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7701 {
7702     I32 oldsavestack_ix = PL_savestack_ix;
7703     CV* outsidecv = PL_compcv;
7704
7705     if (PL_compcv) {
7706         assert(SvTYPE(PL_compcv) == SVt_PVCV);
7707     }
7708     SAVEI32(PL_subline);
7709     save_item(PL_subname);
7710     SAVESPTR(PL_compcv);
7711
7712     PL_compcv = (CV*)NEWSV(1104,0);
7713     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7714     CvFLAGS(PL_compcv) |= flags;
7715
7716     PL_subline = CopLINE(PL_curcop);
7717     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
7718     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7719     CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
7720
7721     return oldsavestack_ix;
7722 }
7723
7724 #ifdef __SC__
7725 #pragma segment Perl_yylex
7726 #endif
7727 int
7728 Perl_yywarn(pTHX_ char *s)
7729 {
7730     PL_in_eval |= EVAL_WARNONLY;
7731     yyerror(s);
7732     PL_in_eval &= ~EVAL_WARNONLY;
7733     return 0;
7734 }
7735
7736 int
7737 Perl_yyerror(pTHX_ char *s)
7738 {
7739     char *where = NULL;
7740     char *context = NULL;
7741     int contlen = -1;
7742     SV *msg;
7743
7744     if (!yychar || (yychar == ';' && !PL_rsfp))
7745         where = "at EOF";
7746     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7747       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7748         /*
7749                 Only for NetWare:
7750                 The code below is removed for NetWare because it abends/crashes on NetWare
7751                 when the script has error such as not having the closing quotes like:
7752                     if ($var eq "value)
7753                 Checking of white spaces is anyway done in NetWare code.
7754         */
7755 #ifndef NETWARE
7756         while (isSPACE(*PL_oldoldbufptr))
7757             PL_oldoldbufptr++;
7758 #endif
7759         context = PL_oldoldbufptr;
7760         contlen = PL_bufptr - PL_oldoldbufptr;
7761     }
7762     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7763       PL_oldbufptr != PL_bufptr) {
7764         /*
7765                 Only for NetWare:
7766                 The code below is removed for NetWare because it abends/crashes on NetWare
7767                 when the script has error such as not having the closing quotes like:
7768                     if ($var eq "value)
7769                 Checking of white spaces is anyway done in NetWare code.
7770         */
7771 #ifndef NETWARE
7772         while (isSPACE(*PL_oldbufptr))
7773             PL_oldbufptr++;
7774 #endif
7775         context = PL_oldbufptr;
7776         contlen = PL_bufptr - PL_oldbufptr;
7777     }
7778     else if (yychar > 255)
7779         where = "next token ???";
7780     else if (yychar == -2) { /* YYEMPTY */
7781         if (PL_lex_state == LEX_NORMAL ||
7782            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7783             where = "at end of line";
7784         else if (PL_lex_inpat)
7785             where = "within pattern";
7786         else
7787             where = "within string";
7788     }
7789     else {
7790         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7791         if (yychar < 32)
7792             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7793         else if (isPRINT_LC(yychar))
7794             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7795         else
7796             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7797         where = SvPVX(where_sv);
7798     }
7799     msg = sv_2mortal(newSVpv(s, 0));
7800     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7801         OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7802     if (context)
7803         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7804     else
7805         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7806     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7807         Perl_sv_catpvf(aTHX_ msg,
7808         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7809                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7810         PL_multi_end = 0;
7811     }
7812     if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
7813         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
7814     else
7815         qerror(msg);
7816     if (PL_error_count >= 10) {
7817         if (PL_in_eval && SvCUR(ERRSV))
7818             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7819             ERRSV, OutCopFILE(PL_curcop));
7820         else
7821             Perl_croak(aTHX_ "%s has too many errors.\n",
7822             OutCopFILE(PL_curcop));
7823     }
7824     PL_in_my = 0;
7825     PL_in_my_stash = Nullhv;
7826     return 0;
7827 }
7828 #ifdef __SC__
7829 #pragma segment Main
7830 #endif
7831
7832 STATIC char*
7833 S_swallow_bom(pTHX_ U8 *s)
7834 {
7835     STRLEN slen;
7836     slen = SvCUR(PL_linestr);
7837     switch (*s) {
7838     case 0xFF:
7839         if (s[1] == 0xFE) {
7840             /* UTF-16 little-endian */
7841             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
7842                 Perl_croak(aTHX_ "Unsupported script encoding");
7843 #ifndef PERL_NO_UTF16_FILTER
7844             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7845             s += 2;
7846             if (PL_bufend > (char*)s) {
7847                 U8 *news;
7848                 I32 newlen;
7849
7850                 filter_add(utf16rev_textfilter, NULL);
7851                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7852                 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7853                                                  PL_bufend - (char*)s - 1,
7854                                                  &newlen);
7855                 Copy(news, s, newlen, U8);
7856                 SvCUR_set(PL_linestr, newlen);
7857                 PL_bufend = SvPVX(PL_linestr) + newlen;
7858                 news[newlen++] = '\0';
7859                 Safefree(news);
7860             }
7861 #else
7862             Perl_croak(aTHX_ "Unsupported script encoding");
7863 #endif
7864         }
7865         break;
7866     case 0xFE:
7867         if (s[1] == 0xFF) {   /* UTF-16 big-endian */
7868 #ifndef PERL_NO_UTF16_FILTER
7869             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7870             s += 2;
7871             if (PL_bufend > (char *)s) {
7872                 U8 *news;
7873                 I32 newlen;
7874
7875                 filter_add(utf16_textfilter, NULL);
7876                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7877                 PL_bufend = (char*)utf16_to_utf8(s, news,
7878                                                  PL_bufend - (char*)s,
7879                                                  &newlen);
7880                 Copy(news, s, newlen, U8);
7881                 SvCUR_set(PL_linestr, newlen);
7882                 PL_bufend = SvPVX(PL_linestr) + newlen;
7883                 news[newlen++] = '\0';
7884                 Safefree(news);
7885             }
7886 #else
7887             Perl_croak(aTHX_ "Unsupported script encoding");
7888 #endif
7889         }
7890         break;
7891     case 0xEF:
7892         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7893             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7894             s += 3;                      /* UTF-8 */
7895         }
7896         break;
7897     case 0:
7898         if (slen > 3 && s[1] == 0 &&  /* UTF-32 big-endian */
7899             s[2] == 0xFE && s[3] == 0xFF)
7900         {
7901             Perl_croak(aTHX_ "Unsupported script encoding");
7902         }
7903     }
7904     return (char*)s;
7905 }
7906
7907 /*
7908  * restore_rsfp
7909  * Restore a source filter.
7910  */
7911
7912 static void
7913 restore_rsfp(pTHX_ void *f)
7914 {
7915     PerlIO *fp = (PerlIO*)f;
7916
7917     if (PL_rsfp == PerlIO_stdin())
7918         PerlIO_clearerr(PL_rsfp);
7919     else if (PL_rsfp && (PL_rsfp != fp))
7920         PerlIO_close(PL_rsfp);
7921     PL_rsfp = fp;
7922 }
7923
7924 #ifndef PERL_NO_UTF16_FILTER
7925 static I32
7926 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7927 {
7928     I32 count = FILTER_READ(idx+1, sv, maxlen);
7929     if (count) {
7930         U8* tmps;
7931         U8* tend;
7932         I32 newlen;
7933         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7934         if (!*SvPV_nolen(sv))
7935         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7936         return count;
7937
7938         tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7939         sv_usepvn(sv, (char*)tmps, tend - tmps);
7940     }
7941     return count;
7942 }
7943
7944 static I32
7945 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7946 {
7947     I32 count = FILTER_READ(idx+1, sv, maxlen);
7948     if (count) {
7949         U8* tmps;
7950         U8* tend;
7951         I32 newlen;
7952         if (!*SvPV_nolen(sv))
7953         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7954         return count;
7955
7956         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7957         tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7958         sv_usepvn(sv, (char*)tmps, tend - tmps);
7959     }
7960     return count;
7961 }
7962 #endif
7963
7964 /*
7965 Returns a pointer to the next character after the parsed
7966 vstring, as well as updating the passed in sv.
7967
7968 Function must be called like
7969
7970         sv = NEWSV(92,5);
7971         s = scan_vstring(s,sv);
7972
7973 The sv should already be large enough to store the vstring
7974 passed in, for performance reasons.
7975
7976 */
7977
7978 char *
7979 Perl_scan_vstring(pTHX_ char *s, SV *sv)
7980 {
7981     char *pos = s;
7982     char *start = s;
7983     if (*pos == 'v') pos++;  /* get past 'v' */
7984     while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
7985         pos++;
7986     if ( *pos != '.') {
7987         /* this may not be a v-string if followed by => */
7988         char *next = pos;
7989         while (next < PL_bufend && isSPACE(*next))
7990             ++next;
7991         if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
7992             /* return string not v-string */
7993             sv_setpvn(sv,(char *)s,pos-s);
7994             return pos;
7995         }
7996     }
7997
7998     if (!isALPHA(*pos)) {
7999         UV rev;
8000         U8 tmpbuf[UTF8_MAXLEN+1];
8001         U8 *tmpend;
8002
8003         if (*s == 'v') s++;  /* get past 'v' */
8004
8005         sv_setpvn(sv, "", 0);
8006
8007         for (;;) {
8008             rev = 0;
8009             {
8010                 /* this is atoi() that tolerates underscores */
8011                 char *end = pos;
8012                 UV mult = 1;
8013                 while (--end >= s) {
8014                     UV orev;
8015                     if (*end == '_')
8016                         continue;
8017                     orev = rev;
8018                     rev += (*end - '0') * mult;
8019                     mult *= 10;
8020                     if (orev > rev && ckWARN_d(WARN_OVERFLOW))
8021                         Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
8022                                     "Integer overflow in decimal number");
8023                 }
8024             }
8025 #ifdef EBCDIC
8026             if (rev > 0x7FFFFFFF)
8027                  Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
8028 #endif
8029             /* Append native character for the rev point */
8030             tmpend = uvchr_to_utf8(tmpbuf, rev);
8031             sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
8032             if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
8033                  SvUTF8_on(sv);
8034             if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
8035                  s = ++pos;
8036             else {
8037                  s = pos;
8038                  break;
8039             }
8040             while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
8041                  pos++;
8042         }
8043         SvPOK_on(sv);
8044         sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
8045         SvRMAGICAL_on(sv);
8046     }
8047     return s;
8048 }
8049