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