Upgrade to Term::ANSIColor 1.04.
[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 named $^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 = (char)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++ = (char)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("()| \r\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         return S_pending_ident(aTHX);
2171
2172     /* no identifier pending identification */
2173
2174     switch (PL_lex_state) {
2175 #ifdef COMMENTARY
2176     case LEX_NORMAL:            /* Some compilers will produce faster */
2177     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2178         break;
2179 #endif
2180
2181     /* when we've already built the next token, just pull it out of the queue */
2182     case LEX_KNOWNEXT:
2183         PL_nexttoke--;
2184         yylval = PL_nextval[PL_nexttoke];
2185         if (!PL_nexttoke) {
2186             PL_lex_state = PL_lex_defer;
2187             PL_expect = PL_lex_expect;
2188             PL_lex_defer = LEX_NORMAL;
2189         }
2190         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2191               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2192               (IV)PL_nexttype[PL_nexttoke]); });
2193
2194         return(PL_nexttype[PL_nexttoke]);
2195
2196     /* interpolated case modifiers like \L \U, including \Q and \E.
2197        when we get here, PL_bufptr is at the \
2198     */
2199     case LEX_INTERPCASEMOD:
2200 #ifdef DEBUGGING
2201         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2202             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2203 #endif
2204         /* handle \E or end of string */
2205         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2206             char oldmod;
2207
2208             /* if at a \E */
2209             if (PL_lex_casemods) {
2210                 oldmod = PL_lex_casestack[--PL_lex_casemods];
2211                 PL_lex_casestack[PL_lex_casemods] = '\0';
2212
2213                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2214                     PL_bufptr += 2;
2215                     PL_lex_state = LEX_INTERPCONCAT;
2216                 }
2217                 return ')';
2218             }
2219             if (PL_bufptr != PL_bufend)
2220                 PL_bufptr += 2;
2221             PL_lex_state = LEX_INTERPCONCAT;
2222             return yylex();
2223         }
2224         else {
2225             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2226               "### Saw case modifier at '%s'\n", PL_bufptr); });
2227             s = PL_bufptr + 1;
2228             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2229                 tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
2230             if (strchr("LU", *s) &&
2231                 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2232             {
2233                 PL_lex_casestack[--PL_lex_casemods] = '\0';
2234                 return ')';
2235             }
2236             if (PL_lex_casemods > 10) {
2237                 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2238                 if (newlb != PL_lex_casestack) {
2239                     SAVEFREEPV(newlb);
2240                     PL_lex_casestack = newlb;
2241                 }
2242             }
2243             PL_lex_casestack[PL_lex_casemods++] = *s;
2244             PL_lex_casestack[PL_lex_casemods] = '\0';
2245             PL_lex_state = LEX_INTERPCONCAT;
2246             PL_nextval[PL_nexttoke].ival = 0;
2247             force_next('(');
2248             if (*s == 'l')
2249                 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2250             else if (*s == 'u')
2251                 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2252             else if (*s == 'L')
2253                 PL_nextval[PL_nexttoke].ival = OP_LC;
2254             else if (*s == 'U')
2255                 PL_nextval[PL_nexttoke].ival = OP_UC;
2256             else if (*s == 'Q')
2257                 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2258             else
2259                 Perl_croak(aTHX_ "panic: yylex");
2260             PL_bufptr = s + 1;
2261             force_next(FUNC);
2262             if (PL_lex_starts) {
2263                 s = PL_bufptr;
2264                 PL_lex_starts = 0;
2265                 Aop(OP_CONCAT);
2266             }
2267             else
2268                 return yylex();
2269         }
2270
2271     case LEX_INTERPPUSH:
2272         return sublex_push();
2273
2274     case LEX_INTERPSTART:
2275         if (PL_bufptr == PL_bufend)
2276             return sublex_done();
2277         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2278               "### Interpolated variable at '%s'\n", PL_bufptr); });
2279         PL_expect = XTERM;
2280         PL_lex_dojoin = (*PL_bufptr == '@');
2281         PL_lex_state = LEX_INTERPNORMAL;
2282         if (PL_lex_dojoin) {
2283             PL_nextval[PL_nexttoke].ival = 0;
2284             force_next(',');
2285 #ifdef USE_THREADS
2286             PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2287             PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2288             force_next(PRIVATEREF);
2289 #else
2290             force_ident("\"", '$');
2291 #endif /* USE_THREADS */
2292             PL_nextval[PL_nexttoke].ival = 0;
2293             force_next('$');
2294             PL_nextval[PL_nexttoke].ival = 0;
2295             force_next('(');
2296             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2297             force_next(FUNC);
2298         }
2299         if (PL_lex_starts++) {
2300             s = PL_bufptr;
2301             Aop(OP_CONCAT);
2302         }
2303         return yylex();
2304
2305     case LEX_INTERPENDMAYBE:
2306         if (intuit_more(PL_bufptr)) {
2307             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2308             break;
2309         }
2310         /* FALL THROUGH */
2311
2312     case LEX_INTERPEND:
2313         if (PL_lex_dojoin) {
2314             PL_lex_dojoin = FALSE;
2315             PL_lex_state = LEX_INTERPCONCAT;
2316             return ')';
2317         }
2318         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2319             && SvEVALED(PL_lex_repl))
2320         {
2321             if (PL_bufptr != PL_bufend)
2322                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2323             PL_lex_repl = Nullsv;
2324         }
2325         /* FALLTHROUGH */
2326     case LEX_INTERPCONCAT:
2327 #ifdef DEBUGGING
2328         if (PL_lex_brackets)
2329             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2330 #endif
2331         if (PL_bufptr == PL_bufend)
2332             return sublex_done();
2333
2334         if (SvIVX(PL_linestr) == '\'') {
2335             SV *sv = newSVsv(PL_linestr);
2336             if (!PL_lex_inpat)
2337                 sv = tokeq(sv);
2338             else if ( PL_hints & HINT_NEW_RE )
2339                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2340             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2341             s = PL_bufend;
2342         }
2343         else {
2344             s = scan_const(PL_bufptr);
2345             if (*s == '\\')
2346                 PL_lex_state = LEX_INTERPCASEMOD;
2347             else
2348                 PL_lex_state = LEX_INTERPSTART;
2349         }
2350
2351         if (s != PL_bufptr) {
2352             PL_nextval[PL_nexttoke] = yylval;
2353             PL_expect = XTERM;
2354             force_next(THING);
2355             if (PL_lex_starts++)
2356                 Aop(OP_CONCAT);
2357             else {
2358                 PL_bufptr = s;
2359                 return yylex();
2360             }
2361         }
2362
2363         return yylex();
2364     case LEX_FORMLINE:
2365         PL_lex_state = LEX_NORMAL;
2366         s = scan_formline(PL_bufptr);
2367         if (!PL_lex_formbrack)
2368             goto rightbracket;
2369         OPERATOR(';');
2370     }
2371
2372     s = PL_bufptr;
2373     PL_oldoldbufptr = PL_oldbufptr;
2374     PL_oldbufptr = s;
2375     DEBUG_T( {
2376         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2377                       exp_name[PL_expect], s);
2378     } );
2379
2380   retry:
2381     switch (*s) {
2382     default:
2383         if (isIDFIRST_lazy_if(s,UTF))
2384             goto keylookup;
2385         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2386     case 4:
2387     case 26:
2388         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2389     case 0:
2390         if (!PL_rsfp) {
2391             PL_last_uni = 0;
2392             PL_last_lop = 0;
2393             if (PL_lex_brackets)
2394                 yyerror("Missing right curly or square bracket");
2395             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2396                         "### Tokener got EOF\n");
2397             } );
2398             TOKEN(0);
2399         }
2400         if (s++ < PL_bufend)
2401             goto retry;                 /* ignore stray nulls */
2402         PL_last_uni = 0;
2403         PL_last_lop = 0;
2404         if (!PL_in_eval && !PL_preambled) {
2405             PL_preambled = TRUE;
2406             sv_setpv(PL_linestr,incl_perldb());
2407             if (SvCUR(PL_linestr))
2408                 sv_catpv(PL_linestr,";");
2409             if (PL_preambleav){
2410                 while(AvFILLp(PL_preambleav) >= 0) {
2411                     SV *tmpsv = av_shift(PL_preambleav);
2412                     sv_catsv(PL_linestr, tmpsv);
2413                     sv_catpv(PL_linestr, ";");
2414                     sv_free(tmpsv);
2415                 }
2416                 sv_free((SV*)PL_preambleav);
2417                 PL_preambleav = NULL;
2418             }
2419             if (PL_minus_n || PL_minus_p) {
2420                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2421                 if (PL_minus_l)
2422                     sv_catpv(PL_linestr,"chomp;");
2423                 if (PL_minus_a) {
2424                     if (PL_minus_F) {
2425                         if (strchr("/'\"", *PL_splitstr)
2426                               && strchr(PL_splitstr + 1, *PL_splitstr))
2427                             Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2428                         else {
2429                             char delim;
2430                             s = "'~#\200\1'"; /* surely one char is unused...*/
2431                             while (s[1] && strchr(PL_splitstr, *s))  s++;
2432                             delim = *s;
2433                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2434                                       "q" + (delim == '\''), delim);
2435                             for (s = PL_splitstr; *s; s++) {
2436                                 if (*s == '\\')
2437                                     sv_catpvn(PL_linestr, "\\", 1);
2438                                 sv_catpvn(PL_linestr, s, 1);
2439                             }
2440                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2441                         }
2442                     }
2443                     else
2444                         sv_catpv(PL_linestr,"our @F=split(' ');");
2445                 }
2446             }
2447             sv_catpv(PL_linestr, "\n");
2448             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2449             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2450             PL_last_lop = PL_last_uni = Nullch;
2451             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2452                 SV *sv = NEWSV(85,0);
2453
2454                 sv_upgrade(sv, SVt_PVMG);
2455                 sv_setsv(sv,PL_linestr);
2456                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2457             }
2458             goto retry;
2459         }
2460         do {
2461             bof = PL_rsfp ? TRUE : FALSE;
2462             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2463               fake_eof:
2464                 if (PL_rsfp) {
2465                     if (PL_preprocess && !PL_in_eval)
2466                         (void)PerlProc_pclose(PL_rsfp);
2467                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2468                         PerlIO_clearerr(PL_rsfp);
2469                     else
2470                         (void)PerlIO_close(PL_rsfp);
2471                     PL_rsfp = Nullfp;
2472                     PL_doextract = FALSE;
2473                 }
2474                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2475                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2476                     sv_catpv(PL_linestr,";}");
2477                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2478                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2479                     PL_last_lop = PL_last_uni = Nullch;
2480                     PL_minus_n = PL_minus_p = 0;
2481                     goto retry;
2482                 }
2483                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2484                 PL_last_lop = PL_last_uni = Nullch;
2485                 sv_setpv(PL_linestr,"");
2486                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2487             }
2488             /* if it looks like the start of a BOM, check if it in fact is */
2489             else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2490 #ifdef PERLIO_IS_STDIO
2491 #  ifdef __GNU_LIBRARY__
2492 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2493 #      define FTELL_FOR_PIPE_IS_BROKEN
2494 #    endif
2495 #  else
2496 #    ifdef __GLIBC__
2497 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2498 #        define FTELL_FOR_PIPE_IS_BROKEN
2499 #      endif
2500 #    endif
2501 #  endif
2502 #endif
2503 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2504                 /* This loses the possibility to detect the bof
2505                  * situation on perl -P when the libc5 is being used.
2506                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2507                  */
2508                 if (!PL_preprocess)
2509                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2510 #else
2511                 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2512 #endif
2513                 if (bof) {
2514                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2515                     s = swallow_bom((U8*)s);
2516                 }
2517             }
2518             if (PL_doextract) {
2519                 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2520                     PL_doextract = FALSE;
2521
2522                 /* Incest with pod. */
2523                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2524                     sv_setpv(PL_linestr, "");
2525                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2526                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2527                     PL_last_lop = PL_last_uni = Nullch;
2528                     PL_doextract = FALSE;
2529                 }
2530             }
2531             incline(s);
2532         } while (PL_doextract);
2533         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2534         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2535             SV *sv = NEWSV(85,0);
2536
2537             sv_upgrade(sv, SVt_PVMG);
2538             sv_setsv(sv,PL_linestr);
2539             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2540         }
2541         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2542         PL_last_lop = PL_last_uni = Nullch;
2543         if (CopLINE(PL_curcop) == 1) {
2544             while (s < PL_bufend && isSPACE(*s))
2545                 s++;
2546             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2547                 s++;
2548             d = Nullch;
2549             if (!PL_in_eval) {
2550                 if (*s == '#' && *(s+1) == '!')
2551                     d = s + 2;
2552 #ifdef ALTERNATE_SHEBANG
2553                 else {
2554                     static char as[] = ALTERNATE_SHEBANG;
2555                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2556                         d = s + (sizeof(as) - 1);
2557                 }
2558 #endif /* ALTERNATE_SHEBANG */
2559             }
2560             if (d) {
2561                 char *ipath;
2562                 char *ipathend;
2563
2564                 while (isSPACE(*d))
2565                     d++;
2566                 ipath = d;
2567                 while (*d && !isSPACE(*d))
2568                     d++;
2569                 ipathend = d;
2570
2571 #ifdef ARG_ZERO_IS_SCRIPT
2572                 if (ipathend > ipath) {
2573                     /*
2574                      * HP-UX (at least) sets argv[0] to the script name,
2575                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2576                      * at least, set argv[0] to the basename of the Perl
2577                      * interpreter. So, having found "#!", we'll set it right.
2578                      */
2579                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2580                     assert(SvPOK(x) || SvGMAGICAL(x));
2581                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2582                         sv_setpvn(x, ipath, ipathend - ipath);
2583                         SvSETMAGIC(x);
2584                     }
2585                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2586                 }
2587 #endif /* ARG_ZERO_IS_SCRIPT */
2588
2589                 /*
2590                  * Look for options.
2591                  */
2592                 d = instr(s,"perl -");
2593                 if (!d) {
2594                     d = instr(s,"perl");
2595 #if defined(DOSISH)
2596                     /* avoid getting into infinite loops when shebang
2597                      * line contains "Perl" rather than "perl" */
2598                     if (!d) {
2599                         for (d = ipathend-4; d >= ipath; --d) {
2600                             if ((*d == 'p' || *d == 'P')
2601                                 && !ibcmp(d, "perl", 4))
2602                             {
2603                                 break;
2604                             }
2605                         }
2606                         if (d < ipath)
2607                             d = Nullch;
2608                     }
2609 #endif
2610                 }
2611 #ifdef ALTERNATE_SHEBANG
2612                 /*
2613                  * If the ALTERNATE_SHEBANG on this system starts with a
2614                  * character that can be part of a Perl expression, then if
2615                  * we see it but not "perl", we're probably looking at the
2616                  * start of Perl code, not a request to hand off to some
2617                  * other interpreter.  Similarly, if "perl" is there, but
2618                  * not in the first 'word' of the line, we assume the line
2619                  * contains the start of the Perl program.
2620                  */
2621                 if (d && *s != '#') {
2622                     char *c = ipath;
2623                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2624                         c++;
2625                     if (c < d)
2626                         d = Nullch;     /* "perl" not in first word; ignore */
2627                     else
2628                         *s = '#';       /* Don't try to parse shebang line */
2629                 }
2630 #endif /* ALTERNATE_SHEBANG */
2631 #ifndef MACOS_TRADITIONAL
2632                 if (!d &&
2633                     *s == '#' &&
2634                     ipathend > ipath &&
2635                     !PL_minus_c &&
2636                     !instr(s,"indir") &&
2637                     instr(PL_origargv[0],"perl"))
2638                 {
2639                     char **newargv;
2640
2641                     *ipathend = '\0';
2642                     s = ipathend + 1;
2643                     while (s < PL_bufend && isSPACE(*s))
2644                         s++;
2645                     if (s < PL_bufend) {
2646                         Newz(899,newargv,PL_origargc+3,char*);
2647                         newargv[1] = s;
2648                         while (s < PL_bufend && !isSPACE(*s))
2649                             s++;
2650                         *s = '\0';
2651                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2652                     }
2653                     else
2654                         newargv = PL_origargv;
2655                     newargv[0] = ipath;
2656                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2657                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2658                 }
2659 #endif
2660                 if (d) {
2661                     U32 oldpdb = PL_perldb;
2662                     bool oldn = PL_minus_n;
2663                     bool oldp = PL_minus_p;
2664
2665                     while (*d && !isSPACE(*d)) d++;
2666                     while (SPACE_OR_TAB(*d)) d++;
2667
2668                     if (*d++ == '-') {
2669                         do {
2670                             if (*d == 'M' || *d == 'm') {
2671                                 char *m = d;
2672                                 while (*d && !isSPACE(*d)) d++;
2673                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2674                                       (int)(d - m), m);
2675                             }
2676                             d = moreswitches(d);
2677                         } while (d);
2678                         if ((PERLDB_LINE && !oldpdb) ||
2679                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2680                               /* if we have already added "LINE: while (<>) {",
2681                                  we must not do it again */
2682                         {
2683                             sv_setpv(PL_linestr, "");
2684                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2685                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2686                             PL_last_lop = PL_last_uni = Nullch;
2687                             PL_preambled = FALSE;
2688                             if (PERLDB_LINE)
2689                                 (void)gv_fetchfile(PL_origfilename);
2690                             goto retry;
2691                         }
2692                     }
2693                 }
2694             }
2695         }
2696         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2697             PL_bufptr = s;
2698             PL_lex_state = LEX_FORMLINE;
2699             return yylex();
2700         }
2701         goto retry;
2702     case '\r':
2703 #ifdef PERL_STRICT_CR
2704         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2705         Perl_croak(aTHX_
2706       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2707 #endif
2708     case ' ': case '\t': case '\f': case 013:
2709 #ifdef MACOS_TRADITIONAL
2710     case '\312':
2711 #endif
2712         s++;
2713         goto retry;
2714     case '#':
2715     case '\n':
2716         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2717             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2718                 /* handle eval qq[#line 1 "foo"\n ...] */
2719                 CopLINE_dec(PL_curcop);
2720                 incline(s);
2721             }
2722             d = PL_bufend;
2723             while (s < d && *s != '\n')
2724                 s++;
2725             if (s < d)
2726                 s++;
2727             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2728               Perl_croak(aTHX_ "panic: input overflow");
2729             incline(s);
2730             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2731                 PL_bufptr = s;
2732                 PL_lex_state = LEX_FORMLINE;
2733                 return yylex();
2734             }
2735         }
2736         else {
2737             *s = '\0';
2738             PL_bufend = s;
2739         }
2740         goto retry;
2741     case '-':
2742         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2743             I32 ftst = 0;
2744
2745             s++;
2746             PL_bufptr = s;
2747             tmp = *s++;
2748
2749             while (s < PL_bufend && SPACE_OR_TAB(*s))
2750                 s++;
2751
2752             if (strnEQ(s,"=>",2)) {
2753                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2754                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2755                             "### Saw unary minus before =>, forcing word '%s'\n", s);
2756                 } );
2757                 OPERATOR('-');          /* unary minus */
2758             }
2759             PL_last_uni = PL_oldbufptr;
2760             switch (tmp) {
2761             case 'r': ftst = OP_FTEREAD;        break;
2762             case 'w': ftst = OP_FTEWRITE;       break;
2763             case 'x': ftst = OP_FTEEXEC;        break;
2764             case 'o': ftst = OP_FTEOWNED;       break;
2765             case 'R': ftst = OP_FTRREAD;        break;
2766             case 'W': ftst = OP_FTRWRITE;       break;
2767             case 'X': ftst = OP_FTREXEC;        break;
2768             case 'O': ftst = OP_FTROWNED;       break;
2769             case 'e': ftst = OP_FTIS;           break;
2770             case 'z': ftst = OP_FTZERO;         break;
2771             case 's': ftst = OP_FTSIZE;         break;
2772             case 'f': ftst = OP_FTFILE;         break;
2773             case 'd': ftst = OP_FTDIR;          break;
2774             case 'l': ftst = OP_FTLINK;         break;
2775             case 'p': ftst = OP_FTPIPE;         break;
2776             case 'S': ftst = OP_FTSOCK;         break;
2777             case 'u': ftst = OP_FTSUID;         break;
2778             case 'g': ftst = OP_FTSGID;         break;
2779             case 'k': ftst = OP_FTSVTX;         break;
2780             case 'b': ftst = OP_FTBLK;          break;
2781             case 'c': ftst = OP_FTCHR;          break;
2782             case 't': ftst = OP_FTTTY;          break;
2783             case 'T': ftst = OP_FTTEXT;         break;
2784             case 'B': ftst = OP_FTBINARY;       break;
2785             case 'M': case 'A': case 'C':
2786                 gv_fetchpv("\024",TRUE, SVt_PV);
2787                 switch (tmp) {
2788                 case 'M': ftst = OP_FTMTIME;    break;
2789                 case 'A': ftst = OP_FTATIME;    break;
2790                 case 'C': ftst = OP_FTCTIME;    break;
2791                 default:                        break;
2792                 }
2793                 break;
2794             default:
2795                 break;
2796             }
2797             if (ftst) {
2798                 PL_last_lop_op = ftst;
2799                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2800                         "### Saw file test %c\n", (int)ftst);
2801                 } );
2802                 FTST(ftst);
2803             }
2804             else {
2805                 /* Assume it was a minus followed by a one-letter named
2806                  * subroutine call (or a -bareword), then. */
2807                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2808                         "### %c looked like a file test but was not\n",
2809                         (int)ftst);
2810                 } );
2811                 s -= 2;
2812             }
2813         }
2814         tmp = *s++;
2815         if (*s == tmp) {
2816             s++;
2817             if (PL_expect == XOPERATOR)
2818                 TERM(POSTDEC);
2819             else
2820                 OPERATOR(PREDEC);
2821         }
2822         else if (*s == '>') {
2823             s++;
2824             s = skipspace(s);
2825             if (isIDFIRST_lazy_if(s,UTF)) {
2826                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2827                 TOKEN(ARROW);
2828             }
2829             else if (*s == '$')
2830                 OPERATOR(ARROW);
2831             else
2832                 TERM(ARROW);
2833         }
2834         if (PL_expect == XOPERATOR)
2835             Aop(OP_SUBTRACT);
2836         else {
2837             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2838                 check_uni();
2839             OPERATOR('-');              /* unary minus */
2840         }
2841
2842     case '+':
2843         tmp = *s++;
2844         if (*s == tmp) {
2845             s++;
2846             if (PL_expect == XOPERATOR)
2847                 TERM(POSTINC);
2848             else
2849                 OPERATOR(PREINC);
2850         }
2851         if (PL_expect == XOPERATOR)
2852             Aop(OP_ADD);
2853         else {
2854             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2855                 check_uni();
2856             OPERATOR('+');
2857         }
2858
2859     case '*':
2860         if (PL_expect != XOPERATOR) {
2861             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2862             PL_expect = XOPERATOR;
2863             force_ident(PL_tokenbuf, '*');
2864             if (!*PL_tokenbuf)
2865                 PREREF('*');
2866             TERM('*');
2867         }
2868         s++;
2869         if (*s == '*') {
2870             s++;
2871             PWop(OP_POW);
2872         }
2873         Mop(OP_MULTIPLY);
2874
2875     case '%':
2876         if (PL_expect == XOPERATOR) {
2877             ++s;
2878             Mop(OP_MODULO);
2879         }
2880         PL_tokenbuf[0] = '%';
2881         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2882         if (!PL_tokenbuf[1]) {
2883             if (s == PL_bufend)
2884                 yyerror("Final % should be \\% or %name");
2885             PREREF('%');
2886         }
2887         PL_pending_ident = '%';
2888         TERM('%');
2889
2890     case '^':
2891         s++;
2892         BOop(OP_BIT_XOR);
2893     case '[':
2894         PL_lex_brackets++;
2895         /* FALL THROUGH */
2896     case '~':
2897     case ',':
2898         tmp = *s++;
2899         OPERATOR(tmp);
2900     case ':':
2901         if (s[1] == ':') {
2902             len = 0;
2903             goto just_a_word;
2904         }
2905         s++;
2906         switch (PL_expect) {
2907             OP *attrs;
2908         case XOPERATOR:
2909             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2910                 break;
2911             PL_bufptr = s;      /* update in case we back off */
2912             goto grabattrs;
2913         case XATTRBLOCK:
2914             PL_expect = XBLOCK;
2915             goto grabattrs;
2916         case XATTRTERM:
2917             PL_expect = XTERMBLOCK;
2918          grabattrs:
2919             s = skipspace(s);
2920             attrs = Nullop;
2921             while (isIDFIRST_lazy_if(s,UTF)) {
2922                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2923                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2924                     if (tmp < 0) tmp = -tmp;
2925                     switch (tmp) {
2926                     case KEY_or:
2927                     case KEY_and:
2928                     case KEY_for:
2929                     case KEY_unless:
2930                     case KEY_if:
2931                     case KEY_while:
2932                     case KEY_until:
2933                         goto got_attrs;
2934                     default:
2935                         break;
2936                     }
2937                 }
2938                 if (*d == '(') {
2939                     d = scan_str(d,TRUE,TRUE);
2940                     if (!d) {
2941                         /* MUST advance bufptr here to avoid bogus
2942                            "at end of line" context messages from yyerror().
2943                          */
2944                         PL_bufptr = s + len;
2945                         yyerror("Unterminated attribute parameter in attribute list");
2946                         if (attrs)
2947                             op_free(attrs);
2948                         return 0;       /* EOF indicator */
2949                     }
2950                 }
2951                 if (PL_lex_stuff) {
2952                     SV *sv = newSVpvn(s, len);
2953                     sv_catsv(sv, PL_lex_stuff);
2954                     attrs = append_elem(OP_LIST, attrs,
2955                                         newSVOP(OP_CONST, 0, sv));
2956                     SvREFCNT_dec(PL_lex_stuff);
2957                     PL_lex_stuff = Nullsv;
2958                 }
2959                 else {
2960                     if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
2961                         CvLVALUE_on(PL_compcv);
2962                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
2963                         CvLOCKED_on(PL_compcv);
2964                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
2965                         CvMETHOD_on(PL_compcv);
2966 #ifdef USE_ITHREADS
2967       else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "unique", len))
2968                         GvUNIQUE_on(cGVOPx_gv(yylval.opval));
2969 #endif
2970                     /* After we've set the flags, it could be argued that
2971                        we don't need to do the attributes.pm-based setting
2972                        process, and shouldn't bother appending recognized
2973                        flags. To experiment with that, uncomment the
2974                        following "else": */
2975                     else
2976                         attrs = append_elem(OP_LIST, attrs,
2977                                             newSVOP(OP_CONST, 0,
2978                                                     newSVpvn(s, len)));
2979                 }
2980                 s = skipspace(d);
2981                 if (*s == ':' && s[1] != ':')
2982                     s = skipspace(s+1);
2983                 else if (s == d)
2984                     break;      /* require real whitespace or :'s */
2985             }
2986             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2987             if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
2988                 char q = ((*s == '\'') ? '"' : '\'');
2989                 /* If here for an expression, and parsed no attrs, back off. */
2990                 if (tmp == '=' && !attrs) {
2991                     s = PL_bufptr;
2992                     break;
2993                 }
2994                 /* MUST advance bufptr here to avoid bogus "at end of line"
2995                    context messages from yyerror().
2996                  */
2997                 PL_bufptr = s;
2998                 if (!*s)
2999                     yyerror("Unterminated attribute list");
3000                 else
3001                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3002                                       q, *s, q));
3003                 if (attrs)
3004                     op_free(attrs);
3005                 OPERATOR(':');
3006             }
3007         got_attrs:
3008             if (attrs) {
3009                 PL_nextval[PL_nexttoke].opval = attrs;
3010                 force_next(THING);
3011             }
3012             TOKEN(COLONATTR);
3013         }
3014         OPERATOR(':');
3015     case '(':
3016         s++;
3017         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3018             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3019         else
3020             PL_expect = XTERM;
3021         TOKEN('(');
3022     case ';':
3023         CLINE;
3024         tmp = *s++;
3025         OPERATOR(tmp);
3026     case ')':
3027         tmp = *s++;
3028         s = skipspace(s);
3029         if (*s == '{')
3030             PREBLOCK(tmp);
3031         TERM(tmp);
3032     case ']':
3033         s++;
3034         if (PL_lex_brackets <= 0)
3035             yyerror("Unmatched right square bracket");
3036         else
3037             --PL_lex_brackets;
3038         if (PL_lex_state == LEX_INTERPNORMAL) {
3039             if (PL_lex_brackets == 0) {
3040                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3041                     PL_lex_state = LEX_INTERPEND;
3042             }
3043         }
3044         TERM(']');
3045     case '{':
3046       leftbracket:
3047         s++;
3048         if (PL_lex_brackets > 100) {
3049             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3050             if (newlb != PL_lex_brackstack) {
3051                 SAVEFREEPV(newlb);
3052                 PL_lex_brackstack = newlb;
3053             }
3054         }
3055         switch (PL_expect) {
3056         case XTERM:
3057             if (PL_lex_formbrack) {
3058                 s--;
3059                 PRETERMBLOCK(DO);
3060             }
3061             if (PL_oldoldbufptr == PL_last_lop)
3062                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3063             else
3064                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3065             OPERATOR(HASHBRACK);
3066         case XOPERATOR:
3067             while (s < PL_bufend && SPACE_OR_TAB(*s))
3068                 s++;
3069             d = s;
3070             PL_tokenbuf[0] = '\0';
3071             if (d < PL_bufend && *d == '-') {
3072                 PL_tokenbuf[0] = '-';
3073                 d++;
3074                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3075                     d++;
3076             }
3077             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3078                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3079                               FALSE, &len);
3080                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3081                     d++;
3082                 if (*d == '}') {
3083                     char minus = (PL_tokenbuf[0] == '-');
3084                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3085                     if (minus)
3086                         force_next('-');
3087                 }
3088             }
3089             /* FALL THROUGH */
3090         case XATTRBLOCK:
3091         case XBLOCK:
3092             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3093             PL_expect = XSTATE;
3094             break;
3095         case XATTRTERM:
3096         case XTERMBLOCK:
3097             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3098             PL_expect = XSTATE;
3099             break;
3100         default: {
3101                 char *t;
3102                 if (PL_oldoldbufptr == PL_last_lop)
3103                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3104                 else
3105                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3106                 s = skipspace(s);
3107                 if (*s == '}') {
3108                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3109                         PL_expect = XTERM;
3110                         /* This hack is to get the ${} in the message. */
3111                         PL_bufptr = s+1;
3112                         yyerror("syntax error");
3113                         break;
3114                     }
3115                     OPERATOR(HASHBRACK);
3116                 }
3117                 /* This hack serves to disambiguate a pair of curlies
3118                  * as being a block or an anon hash.  Normally, expectation
3119                  * determines that, but in cases where we're not in a
3120                  * position to expect anything in particular (like inside
3121                  * eval"") we have to resolve the ambiguity.  This code
3122                  * covers the case where the first term in the curlies is a
3123                  * quoted string.  Most other cases need to be explicitly
3124                  * disambiguated by prepending a `+' before the opening
3125                  * curly in order to force resolution as an anon hash.
3126                  *
3127                  * XXX should probably propagate the outer expectation
3128                  * into eval"" to rely less on this hack, but that could
3129                  * potentially break current behavior of eval"".
3130                  * GSAR 97-07-21
3131                  */
3132                 t = s;
3133                 if (*s == '\'' || *s == '"' || *s == '`') {
3134                     /* common case: get past first string, handling escapes */
3135                     for (t++; t < PL_bufend && *t != *s;)
3136                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3137                             t++;
3138                     t++;
3139                 }
3140                 else if (*s == 'q') {
3141                     if (++t < PL_bufend
3142                         && (!isALNUM(*t)
3143                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3144                                 && !isALNUM(*t))))
3145                     {
3146                         char *tmps;
3147                         char open, close, term;
3148                         I32 brackets = 1;
3149
3150                         while (t < PL_bufend && isSPACE(*t))
3151                             t++;
3152                         term = *t;
3153                         open = term;
3154                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3155                             term = tmps[5];
3156                         close = term;
3157                         if (open == close)
3158                             for (t++; t < PL_bufend; t++) {
3159                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3160                                     t++;
3161                                 else if (*t == open)
3162                                     break;
3163                             }
3164                         else
3165                             for (t++; t < PL_bufend; t++) {
3166                                 if (*t == '\\' && t+1 < PL_bufend)
3167                                     t++;
3168                                 else if (*t == close && --brackets <= 0)
3169                                     break;
3170                                 else if (*t == open)
3171                                     brackets++;
3172                             }
3173                     }
3174                     t++;
3175                 }
3176                 else if (isALNUM_lazy_if(t,UTF)) {
3177                     t += UTF8SKIP(t);
3178                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3179                          t += UTF8SKIP(t);
3180                 }
3181                 while (t < PL_bufend && isSPACE(*t))
3182                     t++;
3183                 /* if comma follows first term, call it an anon hash */
3184                 /* XXX it could be a comma expression with loop modifiers */
3185                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3186                                    || (*t == '=' && t[1] == '>')))
3187                     OPERATOR(HASHBRACK);
3188                 if (PL_expect == XREF)
3189                     PL_expect = XTERM;
3190                 else {
3191                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3192                     PL_expect = XSTATE;
3193                 }
3194             }
3195             break;
3196         }
3197         yylval.ival = CopLINE(PL_curcop);
3198         if (isSPACE(*s) || *s == '#')
3199             PL_copline = NOLINE;   /* invalidate current command line number */
3200         TOKEN('{');
3201     case '}':
3202       rightbracket:
3203         s++;
3204         if (PL_lex_brackets <= 0)
3205             yyerror("Unmatched right curly bracket");
3206         else
3207             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3208         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3209             PL_lex_formbrack = 0;
3210         if (PL_lex_state == LEX_INTERPNORMAL) {
3211             if (PL_lex_brackets == 0) {
3212                 if (PL_expect & XFAKEBRACK) {
3213                     PL_expect &= XENUMMASK;
3214                     PL_lex_state = LEX_INTERPEND;
3215                     PL_bufptr = s;
3216                     return yylex();     /* ignore fake brackets */
3217                 }
3218                 if (*s == '-' && s[1] == '>')
3219                     PL_lex_state = LEX_INTERPENDMAYBE;
3220                 else if (*s != '[' && *s != '{')
3221                     PL_lex_state = LEX_INTERPEND;
3222             }
3223         }
3224         if (PL_expect & XFAKEBRACK) {
3225             PL_expect &= XENUMMASK;
3226             PL_bufptr = s;
3227             return yylex();             /* ignore fake brackets */
3228         }
3229         force_next('}');
3230         TOKEN(';');
3231     case '&':
3232         s++;
3233         tmp = *s++;
3234         if (tmp == '&')
3235             AOPERATOR(ANDAND);
3236         s--;
3237         if (PL_expect == XOPERATOR) {
3238             if (ckWARN(WARN_SEMICOLON)
3239                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3240             {
3241                 CopLINE_dec(PL_curcop);
3242                 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3243                 CopLINE_inc(PL_curcop);
3244             }
3245             BAop(OP_BIT_AND);
3246         }
3247
3248         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3249         if (*PL_tokenbuf) {
3250             PL_expect = XOPERATOR;
3251             force_ident(PL_tokenbuf, '&');
3252         }
3253         else
3254             PREREF('&');
3255         yylval.ival = (OPpENTERSUB_AMPER<<8);
3256         TERM('&');
3257
3258     case '|':
3259         s++;
3260         tmp = *s++;
3261         if (tmp == '|')
3262             AOPERATOR(OROR);
3263         s--;
3264         BOop(OP_BIT_OR);
3265     case '=':
3266         s++;
3267         tmp = *s++;
3268         if (tmp == '=')
3269             Eop(OP_EQ);
3270         if (tmp == '>')
3271             OPERATOR(',');
3272         if (tmp == '~')
3273             PMop(OP_MATCH);
3274         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3275             Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3276         s--;
3277         if (PL_expect == XSTATE && isALPHA(tmp) &&
3278                 (s == PL_linestart+1 || s[-2] == '\n') )
3279         {
3280             if (PL_in_eval && !PL_rsfp) {
3281                 d = PL_bufend;
3282                 while (s < d) {
3283                     if (*s++ == '\n') {
3284                         incline(s);
3285                         if (strnEQ(s,"=cut",4)) {
3286                             s = strchr(s,'\n');
3287                             if (s)
3288                                 s++;
3289                             else
3290                                 s = d;
3291                             incline(s);
3292                             goto retry;
3293                         }
3294                     }
3295                 }
3296                 goto retry;
3297             }
3298             s = PL_bufend;
3299             PL_doextract = TRUE;
3300             goto retry;
3301         }
3302         if (PL_lex_brackets < PL_lex_formbrack) {
3303             char *t;
3304 #ifdef PERL_STRICT_CR
3305             for (t = s; SPACE_OR_TAB(*t); t++) ;
3306 #else
3307             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3308 #endif
3309             if (*t == '\n' || *t == '#') {
3310                 s--;
3311                 PL_expect = XBLOCK;
3312                 goto leftbracket;
3313             }
3314         }
3315         yylval.ival = 0;
3316         OPERATOR(ASSIGNOP);
3317     case '!':
3318         s++;
3319         tmp = *s++;
3320         if (tmp == '=')
3321             Eop(OP_NE);
3322         if (tmp == '~')
3323             PMop(OP_NOT);
3324         s--;
3325         OPERATOR('!');
3326     case '<':
3327         if (PL_expect != XOPERATOR) {
3328             if (s[1] != '<' && !strchr(s,'>'))
3329                 check_uni();
3330             if (s[1] == '<')
3331                 s = scan_heredoc(s);
3332             else
3333                 s = scan_inputsymbol(s);
3334             TERM(sublex_start());
3335         }
3336         s++;
3337         tmp = *s++;
3338         if (tmp == '<')
3339             SHop(OP_LEFT_SHIFT);
3340         if (tmp == '=') {
3341             tmp = *s++;
3342             if (tmp == '>')
3343                 Eop(OP_NCMP);
3344             s--;
3345             Rop(OP_LE);
3346         }
3347         s--;
3348         Rop(OP_LT);
3349     case '>':
3350         s++;
3351         tmp = *s++;
3352         if (tmp == '>')
3353             SHop(OP_RIGHT_SHIFT);
3354         if (tmp == '=')
3355             Rop(OP_GE);
3356         s--;
3357         Rop(OP_GT);
3358
3359     case '$':
3360         CLINE;
3361
3362         if (PL_expect == XOPERATOR) {
3363             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3364                 PL_expect = XTERM;
3365                 depcom();
3366                 return ','; /* grandfather non-comma-format format */
3367             }
3368         }
3369
3370         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3371             PL_tokenbuf[0] = '@';
3372             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3373                            sizeof PL_tokenbuf - 1, FALSE);
3374             if (PL_expect == XOPERATOR)
3375                 no_op("Array length", s);
3376             if (!PL_tokenbuf[1])
3377                 PREREF(DOLSHARP);
3378             PL_expect = XOPERATOR;
3379             PL_pending_ident = '#';
3380             TOKEN(DOLSHARP);
3381         }
3382
3383         PL_tokenbuf[0] = '$';
3384         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3385                        sizeof PL_tokenbuf - 1, FALSE);
3386         if (PL_expect == XOPERATOR)
3387             no_op("Scalar", s);
3388         if (!PL_tokenbuf[1]) {
3389             if (s == PL_bufend)
3390                 yyerror("Final $ should be \\$ or $name");
3391             PREREF('$');
3392         }
3393
3394         /* This kludge not intended to be bulletproof. */
3395         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3396             yylval.opval = newSVOP(OP_CONST, 0,
3397                                    newSViv(PL_compiling.cop_arybase));
3398             yylval.opval->op_private = OPpCONST_ARYBASE;
3399             TERM(THING);
3400         }
3401
3402         d = s;
3403         tmp = (I32)*s;
3404         if (PL_lex_state == LEX_NORMAL)
3405             s = skipspace(s);
3406
3407         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3408             char *t;
3409             if (*s == '[') {
3410                 PL_tokenbuf[0] = '@';
3411                 if (ckWARN(WARN_SYNTAX)) {
3412                     for(t = s + 1;
3413                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3414                         t++) ;
3415                     if (*t++ == ',') {
3416                         PL_bufptr = skipspace(PL_bufptr);
3417                         while (t < PL_bufend && *t != ']')
3418                             t++;
3419                         Perl_warner(aTHX_ WARN_SYNTAX,
3420                                 "Multidimensional syntax %.*s not supported",
3421                                 (t - PL_bufptr) + 1, PL_bufptr);
3422                     }
3423                 }
3424             }
3425             else if (*s == '{') {
3426                 PL_tokenbuf[0] = '%';
3427                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3428                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3429                 {
3430                     char tmpbuf[sizeof PL_tokenbuf];
3431                     STRLEN len;
3432                     for (t++; isSPACE(*t); t++) ;
3433                     if (isIDFIRST_lazy_if(t,UTF)) {
3434                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3435                         for (; isSPACE(*t); t++) ;
3436                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3437                             Perl_warner(aTHX_ WARN_SYNTAX,
3438                                 "You need to quote \"%s\"", tmpbuf);
3439                     }
3440                 }
3441             }
3442         }
3443
3444         PL_expect = XOPERATOR;
3445         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3446             bool islop = (PL_last_lop == PL_oldoldbufptr);
3447             if (!islop || PL_last_lop_op == OP_GREPSTART)
3448                 PL_expect = XOPERATOR;
3449             else if (strchr("$@\"'`q", *s))
3450                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3451             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3452                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3453             else if (isIDFIRST_lazy_if(s,UTF)) {
3454                 char tmpbuf[sizeof PL_tokenbuf];
3455                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3456                 if ((tmp = keyword(tmpbuf, len))) {
3457                     /* binary operators exclude handle interpretations */
3458                     switch (tmp) {
3459                     case -KEY_x:
3460                     case -KEY_eq:
3461                     case -KEY_ne:
3462                     case -KEY_gt:
3463                     case -KEY_lt:
3464                     case -KEY_ge:
3465                     case -KEY_le:
3466                     case -KEY_cmp:
3467                         break;
3468                     default:
3469                         PL_expect = XTERM;      /* e.g. print $fh length() */
3470                         break;
3471                     }
3472                 }
3473                 else {
3474                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3475                     if (gv && GvCVu(gv))
3476                         PL_expect = XTERM;      /* e.g. print $fh subr() */
3477                 }
3478             }
3479             else if (isDIGIT(*s))
3480                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3481             else if (*s == '.' && isDIGIT(s[1]))
3482                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3483             else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3484                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3485             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3486                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3487         }
3488         PL_pending_ident = '$';
3489         TOKEN('$');
3490
3491     case '@':
3492         if (PL_expect == XOPERATOR)
3493             no_op("Array", s);
3494         PL_tokenbuf[0] = '@';
3495         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3496         if (!PL_tokenbuf[1]) {
3497             if (s == PL_bufend)
3498                 yyerror("Final @ should be \\@ or @name");
3499             PREREF('@');
3500         }
3501         if (PL_lex_state == LEX_NORMAL)
3502             s = skipspace(s);
3503         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3504             if (*s == '{')
3505                 PL_tokenbuf[0] = '%';
3506
3507             /* Warn about @ where they meant $. */
3508             if (ckWARN(WARN_SYNTAX)) {
3509                 if (*s == '[' || *s == '{') {
3510                     char *t = s + 1;
3511                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3512                         t++;
3513                     if (*t == '}' || *t == ']') {
3514                         t++;
3515                         PL_bufptr = skipspace(PL_bufptr);
3516                         Perl_warner(aTHX_ WARN_SYNTAX,
3517                             "Scalar value %.*s better written as $%.*s",
3518                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3519                     }
3520                 }
3521             }
3522         }
3523         PL_pending_ident = '@';
3524         TERM('@');
3525
3526     case '/':                   /* may either be division or pattern */
3527     case '?':                   /* may either be conditional or pattern */
3528         if (PL_expect != XOPERATOR) {
3529             /* Disable warning on "study /blah/" */
3530             if (PL_oldoldbufptr == PL_last_uni
3531                 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3532                     || memNE(PL_last_uni, "study", 5)
3533                     || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3534                 check_uni();
3535             s = scan_pat(s,OP_MATCH);
3536             TERM(sublex_start());
3537         }
3538         tmp = *s++;
3539         if (tmp == '/')
3540             Mop(OP_DIVIDE);
3541         OPERATOR(tmp);
3542
3543     case '.':
3544         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3545 #ifdef PERL_STRICT_CR
3546             && s[1] == '\n'
3547 #else
3548             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3549 #endif
3550             && (s == PL_linestart || s[-1] == '\n') )
3551         {
3552             PL_lex_formbrack = 0;
3553             PL_expect = XSTATE;
3554             goto rightbracket;
3555         }
3556         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3557             tmp = *s++;
3558             if (*s == tmp) {
3559                 s++;
3560                 if (*s == tmp) {
3561                     s++;
3562                     yylval.ival = OPf_SPECIAL;
3563                 }
3564                 else
3565                     yylval.ival = 0;
3566                 OPERATOR(DOTDOT);
3567             }
3568             if (PL_expect != XOPERATOR)
3569                 check_uni();
3570             Aop(OP_CONCAT);
3571         }
3572         /* FALL THROUGH */
3573     case '0': case '1': case '2': case '3': case '4':
3574     case '5': case '6': case '7': case '8': case '9':
3575         s = scan_num(s, &yylval);
3576         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3577                     "### Saw number in '%s'\n", s);
3578         } );
3579         if (PL_expect == XOPERATOR)
3580             no_op("Number",s);
3581         TERM(THING);
3582
3583     case '\'':
3584         s = scan_str(s,FALSE,FALSE);
3585         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3586                     "### Saw string before '%s'\n", s);
3587         } );
3588         if (PL_expect == XOPERATOR) {
3589             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3590                 PL_expect = XTERM;
3591                 depcom();
3592                 return ',';     /* grandfather non-comma-format format */
3593             }
3594             else
3595                 no_op("String",s);
3596         }
3597         if (!s)
3598             missingterm((char*)0);
3599         yylval.ival = OP_CONST;
3600         TERM(sublex_start());
3601
3602     case '"':
3603         s = scan_str(s,FALSE,FALSE);
3604         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3605                     "### Saw string before '%s'\n", s);
3606         } );
3607         if (PL_expect == XOPERATOR) {
3608             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3609                 PL_expect = XTERM;
3610                 depcom();
3611                 return ',';     /* grandfather non-comma-format format */
3612             }
3613             else
3614                 no_op("String",s);
3615         }
3616         if (!s)
3617             missingterm((char*)0);
3618         yylval.ival = OP_CONST;
3619         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3620             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3621                 yylval.ival = OP_STRINGIFY;
3622                 break;
3623             }
3624         }
3625         TERM(sublex_start());
3626
3627     case '`':
3628         s = scan_str(s,FALSE,FALSE);
3629         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3630                     "### Saw backtick string before '%s'\n", s);
3631         } );
3632         if (PL_expect == XOPERATOR)
3633             no_op("Backticks",s);
3634         if (!s)
3635             missingterm((char*)0);
3636         yylval.ival = OP_BACKTICK;
3637         set_csh();
3638         TERM(sublex_start());
3639
3640     case '\\':
3641         s++;
3642         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3643             Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3644                         *s, *s);
3645         if (PL_expect == XOPERATOR)
3646             no_op("Backslash",s);
3647         OPERATOR(REFGEN);
3648
3649     case 'v':
3650         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3651             char *start = s;
3652             start++;
3653             start++;
3654             while (isDIGIT(*start) || *start == '_')
3655                 start++;
3656             if (*start == '.' && isDIGIT(start[1])) {
3657                 s = scan_num(s, &yylval);
3658                 TERM(THING);
3659             }
3660             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3661             else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
3662                 char c = *start;
3663                 GV *gv;
3664                 *start = '\0';
3665                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3666                 *start = c;
3667                 if (!gv) {
3668                     s = scan_num(s, &yylval);
3669                     TERM(THING);
3670                 }
3671             }
3672         }
3673         goto keylookup;
3674     case 'x':
3675         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3676             s++;
3677             Mop(OP_REPEAT);
3678         }
3679         goto keylookup;
3680
3681     case '_':
3682     case 'a': case 'A':
3683     case 'b': case 'B':
3684     case 'c': case 'C':
3685     case 'd': case 'D':
3686     case 'e': case 'E':
3687     case 'f': case 'F':
3688     case 'g': case 'G':
3689     case 'h': case 'H':
3690     case 'i': case 'I':
3691     case 'j': case 'J':
3692     case 'k': case 'K':
3693     case 'l': case 'L':
3694     case 'm': case 'M':
3695     case 'n': case 'N':
3696     case 'o': case 'O':
3697     case 'p': case 'P':
3698     case 'q': case 'Q':
3699     case 'r': case 'R':
3700     case 's': case 'S':
3701     case 't': case 'T':
3702     case 'u': case 'U':
3703               case 'V':
3704     case 'w': case 'W':
3705               case 'X':
3706     case 'y': case 'Y':
3707     case 'z': case 'Z':
3708
3709       keylookup: {
3710         gv = Nullgv;
3711         gvp = 0;
3712
3713         PL_bufptr = s;
3714         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3715
3716         /* Some keywords can be followed by any delimiter, including ':' */
3717         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3718                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3719                              (PL_tokenbuf[0] == 'q' &&
3720                               strchr("qwxr", PL_tokenbuf[1])))));
3721
3722         /* x::* is just a word, unless x is "CORE" */
3723         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3724             goto just_a_word;
3725
3726         d = s;
3727         while (d < PL_bufend && isSPACE(*d))
3728                 d++;    /* no comments skipped here, or s### is misparsed */
3729
3730         /* Is this a label? */
3731         if (!tmp && PL_expect == XSTATE
3732               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3733             s = d + 1;
3734             yylval.pval = savepv(PL_tokenbuf);
3735             CLINE;
3736             TOKEN(LABEL);
3737         }
3738
3739         /* Check for keywords */
3740         tmp = keyword(PL_tokenbuf, len);
3741
3742         /* Is this a word before a => operator? */
3743         if (*d == '=' && d[1] == '>') {
3744             CLINE;
3745             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3746             yylval.opval->op_private = OPpCONST_BARE;
3747             if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3748               SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3749             TERM(WORD);
3750         }
3751
3752         if (tmp < 0) {                  /* second-class keyword? */
3753             GV *ogv = Nullgv;   /* override (winner) */
3754             GV *hgv = Nullgv;   /* hidden (loser) */
3755             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3756                 CV *cv;
3757                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3758                     (cv = GvCVu(gv)))
3759                 {
3760                     if (GvIMPORTED_CV(gv))
3761                         ogv = gv;
3762                     else if (! CvMETHOD(cv))
3763                         hgv = gv;
3764                 }
3765                 if (!ogv &&
3766                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3767                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3768                     GvCVu(gv) && GvIMPORTED_CV(gv))
3769                 {
3770                     ogv = gv;
3771                 }
3772             }
3773             if (ogv) {
3774                 tmp = 0;                /* overridden by import or by GLOBAL */
3775             }
3776             else if (gv && !gvp
3777                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3778                      && GvCVu(gv)
3779                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3780             {
3781                 tmp = 0;                /* any sub overrides "weak" keyword */
3782             }
3783             else {                      /* no override */
3784                 tmp = -tmp;
3785                 gv = Nullgv;
3786                 gvp = 0;
3787                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3788                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3789                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3790                         "Ambiguous call resolved as CORE::%s(), %s",
3791                          GvENAME(hgv), "qualify as such or use &");
3792             }
3793         }
3794
3795       reserved_word:
3796         switch (tmp) {
3797
3798         default:                        /* not a keyword */
3799           just_a_word: {
3800                 SV *sv;
3801                 int pkgname = 0;
3802                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3803
3804                 /* Get the rest if it looks like a package qualifier */
3805
3806                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3807                     STRLEN morelen;
3808                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3809                                   TRUE, &morelen);
3810                     if (!morelen)
3811                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3812                                 *s == '\'' ? "'" : "::");
3813                     len += morelen;
3814                     pkgname = 1;
3815                 }
3816
3817                 if (PL_expect == XOPERATOR) {
3818                     if (PL_bufptr == PL_linestart) {
3819                         CopLINE_dec(PL_curcop);
3820                         Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3821                         CopLINE_inc(PL_curcop);
3822                     }
3823                     else
3824                         no_op("Bareword",s);
3825                 }
3826
3827                 /* Look for a subroutine with this name in current package,
3828                    unless name is "Foo::", in which case Foo is a bearword
3829                    (and a package name). */
3830
3831                 if (len > 2 &&
3832                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3833                 {
3834                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3835                         Perl_warner(aTHX_ WARN_BAREWORD,
3836                             "Bareword \"%s\" refers to nonexistent package",
3837                              PL_tokenbuf);
3838                     len -= 2;
3839                     PL_tokenbuf[len] = '\0';
3840                     gv = Nullgv;
3841                     gvp = 0;
3842                 }
3843                 else {
3844                     len = 0;
3845                     if (!gv)
3846                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3847                 }
3848
3849                 /* if we saw a global override before, get the right name */
3850
3851                 if (gvp) {
3852                     sv = newSVpvn("CORE::GLOBAL::",14);
3853                     sv_catpv(sv,PL_tokenbuf);
3854                 }
3855                 else
3856                     sv = newSVpv(PL_tokenbuf,0);
3857
3858                 /* Presume this is going to be a bareword of some sort. */
3859
3860                 CLINE;
3861                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3862                 yylval.opval->op_private = OPpCONST_BARE;
3863
3864                 /* And if "Foo::", then that's what it certainly is. */
3865
3866                 if (len)
3867                     goto safe_bareword;
3868
3869                 /* See if it's the indirect object for a list operator. */
3870
3871                 if (PL_oldoldbufptr &&
3872                     PL_oldoldbufptr < PL_bufptr &&
3873                     (PL_oldoldbufptr == PL_last_lop
3874                      || PL_oldoldbufptr == PL_last_uni) &&
3875                     /* NO SKIPSPACE BEFORE HERE! */
3876                     (PL_expect == XREF ||
3877                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3878                 {
3879                     bool immediate_paren = *s == '(';
3880
3881                     /* (Now we can afford to cross potential line boundary.) */
3882                     s = skipspace(s);
3883
3884                     /* Two barewords in a row may indicate method call. */
3885
3886                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3887                         return tmp;
3888
3889                     /* If not a declared subroutine, it's an indirect object. */
3890                     /* (But it's an indir obj regardless for sort.) */
3891
3892                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
3893                          ((!gv || !GvCVu(gv)) &&
3894                         (PL_last_lop_op != OP_MAPSTART &&
3895                          PL_last_lop_op != OP_GREPSTART))))
3896                     {
3897                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3898                         goto bareword;
3899                     }
3900                 }
3901
3902                 PL_expect = XOPERATOR;
3903                 s = skipspace(s);
3904
3905                 /* Is this a word before a => operator? */
3906                 if (*s == '=' && s[1] == '>' && !pkgname) {
3907                     CLINE;
3908                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3909                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3910                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3911                     TERM(WORD);
3912                 }
3913
3914                 /* If followed by a paren, it's certainly a subroutine. */
3915                 if (*s == '(') {
3916                     CLINE;
3917                     if (gv && GvCVu(gv)) {
3918                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3919                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3920                             s = d + 1;
3921                             goto its_constant;
3922                         }
3923                     }
3924                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3925                     PL_expect = XOPERATOR;
3926                     force_next(WORD);
3927                     yylval.ival = 0;
3928                     TOKEN('&');
3929                 }
3930
3931                 /* If followed by var or block, call it a method (unless sub) */
3932
3933                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3934                     PL_last_lop = PL_oldbufptr;
3935                     PL_last_lop_op = OP_METHOD;
3936                     PREBLOCK(METHOD);
3937                 }
3938
3939                 /* If followed by a bareword, see if it looks like indir obj. */
3940
3941                 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3942                     return tmp;
3943
3944                 /* Not a method, so call it a subroutine (if defined) */
3945
3946                 if (gv && GvCVu(gv)) {
3947                     CV* cv;
3948                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3949                         Perl_warner(aTHX_ WARN_AMBIGUOUS,
3950                                 "Ambiguous use of -%s resolved as -&%s()",
3951                                 PL_tokenbuf, PL_tokenbuf);
3952                     /* Check for a constant sub */
3953                     cv = GvCV(gv);
3954                     if ((sv = cv_const_sv(cv))) {
3955                   its_constant:
3956                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3957                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3958                         yylval.opval->op_private = 0;
3959                         TOKEN(WORD);
3960                     }
3961
3962                     /* Resolve to GV now. */
3963                     op_free(yylval.opval);
3964                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3965                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3966                     PL_last_lop = PL_oldbufptr;
3967                     PL_last_lop_op = OP_ENTERSUB;
3968                     /* Is there a prototype? */
3969                     if (SvPOK(cv)) {
3970                         STRLEN len;
3971                         char *proto = SvPV((SV*)cv, len);
3972                         if (!len)
3973                             TERM(FUNC0SUB);
3974                         if (strEQ(proto, "$"))
3975                             OPERATOR(UNIOPSUB);
3976                         if (*proto == '&' && *s == '{') {
3977                             sv_setpv(PL_subname,"__ANON__");
3978                             PREBLOCK(LSTOPSUB);
3979                         }
3980                     }
3981                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3982                     PL_expect = XTERM;
3983                     force_next(WORD);
3984                     TOKEN(NOAMP);
3985                 }
3986
3987                 /* Call it a bare word */
3988
3989                 if (PL_hints & HINT_STRICT_SUBS)
3990                     yylval.opval->op_private |= OPpCONST_STRICT;
3991                 else {
3992                 bareword:
3993                     if (ckWARN(WARN_RESERVED)) {
3994                         if (lastchar != '-') {
3995                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3996                             if (!*d)
3997                                 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3998                                        PL_tokenbuf);
3999                         }
4000                     }
4001                 }
4002
4003             safe_bareword:
4004                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4005                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4006                         "Operator or semicolon missing before %c%s",
4007                         lastchar, PL_tokenbuf);
4008                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4009                         "Ambiguous use of %c resolved as operator %c",
4010                         lastchar, lastchar);
4011                 }
4012                 TOKEN(WORD);
4013             }
4014
4015         case KEY___FILE__:
4016             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4017                                         newSVpv(CopFILE(PL_curcop),0));
4018             TERM(THING);
4019
4020         case KEY___LINE__:
4021             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4022                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4023             TERM(THING);
4024
4025         case KEY___PACKAGE__:
4026             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4027                                         (PL_curstash
4028                                          ? newSVsv(PL_curstname)
4029                                          : &PL_sv_undef));
4030             TERM(THING);
4031
4032         case KEY___DATA__:
4033         case KEY___END__: {
4034             GV *gv;
4035
4036             /*SUPPRESS 560*/
4037             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4038                 char *pname = "main";
4039                 if (PL_tokenbuf[2] == 'D')
4040                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4041                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4042                 GvMULTI_on(gv);
4043                 if (!GvIO(gv))
4044                     GvIOp(gv) = newIO();
4045                 IoIFP(GvIOp(gv)) = PL_rsfp;
4046 #if defined(HAS_FCNTL) && defined(F_SETFD)
4047                 {
4048                     int fd = PerlIO_fileno(PL_rsfp);
4049                     fcntl(fd,F_SETFD,fd >= 3);
4050                 }
4051 #endif
4052                 /* Mark this internal pseudo-handle as clean */
4053                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4054                 if (PL_preprocess)
4055                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4056                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4057                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4058                 else
4059                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4060 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4061                 /* if the script was opened in binmode, we need to revert
4062                  * it to text mode for compatibility; but only iff it has CRs
4063                  * XXX this is a questionable hack at best. */
4064                 if (PL_bufend-PL_bufptr > 2
4065                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4066                 {
4067                     Off_t loc = 0;
4068                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4069                         loc = PerlIO_tell(PL_rsfp);
4070                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
4071                     }
4072 #ifdef NETWARE
4073                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4074 #else
4075                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4076 #endif  /* NETWARE */
4077 #ifdef PERLIO_IS_STDIO /* really? */
4078 #  if defined(__BORLANDC__)
4079                         /* XXX see note in do_binmode() */
4080                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4081 #  endif
4082 #endif
4083                         if (loc > 0)
4084                             PerlIO_seek(PL_rsfp, loc, 0);
4085                     }
4086                 }
4087 #endif
4088 #ifdef PERLIO_LAYERS
4089                 if (UTF && !IN_BYTES)
4090                     PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4091 #endif
4092                 PL_rsfp = Nullfp;
4093             }
4094             goto fake_eof;
4095         }
4096
4097         case KEY_AUTOLOAD:
4098         case KEY_DESTROY:
4099         case KEY_BEGIN:
4100         case KEY_CHECK:
4101         case KEY_INIT:
4102         case KEY_END:
4103             if (PL_expect == XSTATE) {
4104                 s = PL_bufptr;
4105                 goto really_sub;
4106             }
4107             goto just_a_word;
4108
4109         case KEY_CORE:
4110             if (*s == ':' && s[1] == ':') {
4111                 s += 2;
4112                 d = s;
4113                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4114                 if (!(tmp = keyword(PL_tokenbuf, len)))
4115                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4116                 if (tmp < 0)
4117                     tmp = -tmp;
4118                 goto reserved_word;
4119             }
4120             goto just_a_word;
4121
4122         case KEY_abs:
4123             UNI(OP_ABS);
4124
4125         case KEY_alarm:
4126             UNI(OP_ALARM);
4127
4128         case KEY_accept:
4129             LOP(OP_ACCEPT,XTERM);
4130
4131         case KEY_and:
4132             OPERATOR(ANDOP);
4133
4134         case KEY_atan2:
4135             LOP(OP_ATAN2,XTERM);
4136
4137         case KEY_bind:
4138             LOP(OP_BIND,XTERM);
4139
4140         case KEY_binmode:
4141             LOP(OP_BINMODE,XTERM);
4142
4143         case KEY_bless:
4144             LOP(OP_BLESS,XTERM);
4145
4146         case KEY_chop:
4147             UNI(OP_CHOP);
4148
4149         case KEY_continue:
4150             PREBLOCK(CONTINUE);
4151
4152         case KEY_chdir:
4153             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
4154             UNI(OP_CHDIR);
4155
4156         case KEY_close:
4157             UNI(OP_CLOSE);
4158
4159         case KEY_closedir:
4160             UNI(OP_CLOSEDIR);
4161
4162         case KEY_cmp:
4163             Eop(OP_SCMP);
4164
4165         case KEY_caller:
4166             UNI(OP_CALLER);
4167
4168         case KEY_crypt:
4169 #ifdef FCRYPT
4170             if (!PL_cryptseen) {
4171                 PL_cryptseen = TRUE;
4172                 init_des();
4173             }
4174 #endif
4175             LOP(OP_CRYPT,XTERM);
4176
4177         case KEY_chmod:
4178             LOP(OP_CHMOD,XTERM);
4179
4180         case KEY_chown:
4181             LOP(OP_CHOWN,XTERM);
4182
4183         case KEY_connect:
4184             LOP(OP_CONNECT,XTERM);
4185
4186         case KEY_chr:
4187             UNI(OP_CHR);
4188
4189         case KEY_cos:
4190             UNI(OP_COS);
4191
4192         case KEY_chroot:
4193             UNI(OP_CHROOT);
4194
4195         case KEY_do:
4196             s = skipspace(s);
4197             if (*s == '{')
4198                 PRETERMBLOCK(DO);
4199             if (*s != '\'')
4200                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4201             OPERATOR(DO);
4202
4203         case KEY_die:
4204             PL_hints |= HINT_BLOCK_SCOPE;
4205             LOP(OP_DIE,XTERM);
4206
4207         case KEY_defined:
4208             UNI(OP_DEFINED);
4209
4210         case KEY_delete:
4211             UNI(OP_DELETE);
4212
4213         case KEY_dbmopen:
4214             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4215             LOP(OP_DBMOPEN,XTERM);
4216
4217         case KEY_dbmclose:
4218             UNI(OP_DBMCLOSE);
4219
4220         case KEY_dump:
4221             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4222             LOOPX(OP_DUMP);
4223
4224         case KEY_else:
4225             PREBLOCK(ELSE);
4226
4227         case KEY_elsif:
4228             yylval.ival = CopLINE(PL_curcop);
4229             OPERATOR(ELSIF);
4230
4231         case KEY_eq:
4232             Eop(OP_SEQ);
4233
4234         case KEY_exists:
4235             UNI(OP_EXISTS);
4236         
4237         case KEY_exit:
4238             UNI(OP_EXIT);
4239
4240         case KEY_eval:
4241             s = skipspace(s);
4242             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4243             UNIBRACK(OP_ENTEREVAL);
4244
4245         case KEY_eof:
4246             UNI(OP_EOF);
4247
4248         case KEY_exp:
4249             UNI(OP_EXP);
4250
4251         case KEY_each:
4252             UNI(OP_EACH);
4253
4254         case KEY_exec:
4255             set_csh();
4256             LOP(OP_EXEC,XREF);
4257
4258         case KEY_endhostent:
4259             FUN0(OP_EHOSTENT);
4260
4261         case KEY_endnetent:
4262             FUN0(OP_ENETENT);
4263
4264         case KEY_endservent:
4265             FUN0(OP_ESERVENT);
4266
4267         case KEY_endprotoent:
4268             FUN0(OP_EPROTOENT);
4269
4270         case KEY_endpwent:
4271             FUN0(OP_EPWENT);
4272
4273         case KEY_endgrent:
4274             FUN0(OP_EGRENT);
4275
4276         case KEY_for:
4277         case KEY_foreach:
4278             yylval.ival = CopLINE(PL_curcop);
4279             s = skipspace(s);
4280             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4281                 char *p = s;
4282                 if ((PL_bufend - p) >= 3 &&
4283                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4284                     p += 2;
4285                 else if ((PL_bufend - p) >= 4 &&
4286                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4287                     p += 3;
4288                 p = skipspace(p);
4289                 if (isIDFIRST_lazy_if(p,UTF)) {
4290                     p = scan_ident(p, PL_bufend,
4291                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4292                     p = skipspace(p);
4293                 }
4294                 if (*p != '$')
4295                     Perl_croak(aTHX_ "Missing $ on loop variable");
4296             }
4297             OPERATOR(FOR);
4298
4299         case KEY_formline:
4300             LOP(OP_FORMLINE,XTERM);
4301
4302         case KEY_fork:
4303             FUN0(OP_FORK);
4304
4305         case KEY_fcntl:
4306             LOP(OP_FCNTL,XTERM);
4307
4308         case KEY_fileno:
4309             UNI(OP_FILENO);
4310
4311         case KEY_flock:
4312             LOP(OP_FLOCK,XTERM);
4313
4314         case KEY_gt:
4315             Rop(OP_SGT);
4316
4317         case KEY_ge:
4318             Rop(OP_SGE);
4319
4320         case KEY_grep:
4321             LOP(OP_GREPSTART, XREF);
4322
4323         case KEY_goto:
4324             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4325             LOOPX(OP_GOTO);
4326
4327         case KEY_gmtime:
4328             UNI(OP_GMTIME);
4329
4330         case KEY_getc:
4331             UNI(OP_GETC);
4332
4333         case KEY_getppid:
4334             FUN0(OP_GETPPID);
4335
4336         case KEY_getpgrp:
4337             UNI(OP_GETPGRP);
4338
4339         case KEY_getpriority:
4340             LOP(OP_GETPRIORITY,XTERM);
4341
4342         case KEY_getprotobyname:
4343             UNI(OP_GPBYNAME);
4344
4345         case KEY_getprotobynumber:
4346             LOP(OP_GPBYNUMBER,XTERM);
4347
4348         case KEY_getprotoent:
4349             FUN0(OP_GPROTOENT);
4350
4351         case KEY_getpwent:
4352             FUN0(OP_GPWENT);
4353
4354         case KEY_getpwnam:
4355             UNI(OP_GPWNAM);
4356
4357         case KEY_getpwuid:
4358             UNI(OP_GPWUID);
4359
4360         case KEY_getpeername:
4361             UNI(OP_GETPEERNAME);
4362
4363         case KEY_gethostbyname:
4364             UNI(OP_GHBYNAME);
4365
4366         case KEY_gethostbyaddr:
4367             LOP(OP_GHBYADDR,XTERM);
4368
4369         case KEY_gethostent:
4370             FUN0(OP_GHOSTENT);
4371
4372         case KEY_getnetbyname:
4373             UNI(OP_GNBYNAME);
4374
4375         case KEY_getnetbyaddr:
4376             LOP(OP_GNBYADDR,XTERM);
4377
4378         case KEY_getnetent:
4379             FUN0(OP_GNETENT);
4380
4381         case KEY_getservbyname:
4382             LOP(OP_GSBYNAME,XTERM);
4383
4384         case KEY_getservbyport:
4385             LOP(OP_GSBYPORT,XTERM);
4386
4387         case KEY_getservent:
4388             FUN0(OP_GSERVENT);
4389
4390         case KEY_getsockname:
4391             UNI(OP_GETSOCKNAME);
4392
4393         case KEY_getsockopt:
4394             LOP(OP_GSOCKOPT,XTERM);
4395
4396         case KEY_getgrent:
4397             FUN0(OP_GGRENT);
4398
4399         case KEY_getgrnam:
4400             UNI(OP_GGRNAM);
4401
4402         case KEY_getgrgid:
4403             UNI(OP_GGRGID);
4404
4405         case KEY_getlogin:
4406             FUN0(OP_GETLOGIN);
4407
4408         case KEY_glob:
4409             set_csh();
4410             LOP(OP_GLOB,XTERM);
4411
4412         case KEY_hex:
4413             UNI(OP_HEX);
4414
4415         case KEY_if:
4416             yylval.ival = CopLINE(PL_curcop);
4417             OPERATOR(IF);
4418
4419         case KEY_index:
4420             LOP(OP_INDEX,XTERM);
4421
4422         case KEY_int:
4423             UNI(OP_INT);
4424
4425         case KEY_ioctl:
4426             LOP(OP_IOCTL,XTERM);
4427
4428         case KEY_join:
4429             LOP(OP_JOIN,XTERM);
4430
4431         case KEY_keys:
4432             UNI(OP_KEYS);
4433
4434         case KEY_kill:
4435             LOP(OP_KILL,XTERM);
4436
4437         case KEY_last:
4438             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4439             LOOPX(OP_LAST);
4440         
4441         case KEY_lc:
4442             UNI(OP_LC);
4443
4444         case KEY_lcfirst:
4445             UNI(OP_LCFIRST);
4446
4447         case KEY_local:
4448             yylval.ival = 0;
4449             OPERATOR(LOCAL);
4450
4451         case KEY_length:
4452             UNI(OP_LENGTH);
4453
4454         case KEY_lt:
4455             Rop(OP_SLT);
4456
4457         case KEY_le:
4458             Rop(OP_SLE);
4459
4460         case KEY_localtime:
4461             UNI(OP_LOCALTIME);
4462
4463         case KEY_log:
4464             UNI(OP_LOG);
4465
4466         case KEY_link:
4467             LOP(OP_LINK,XTERM);
4468
4469         case KEY_listen:
4470             LOP(OP_LISTEN,XTERM);
4471
4472         case KEY_lock:
4473             UNI(OP_LOCK);
4474
4475         case KEY_lstat:
4476             UNI(OP_LSTAT);
4477
4478         case KEY_m:
4479             s = scan_pat(s,OP_MATCH);
4480             TERM(sublex_start());
4481
4482         case KEY_map:
4483             LOP(OP_MAPSTART, XREF);
4484
4485         case KEY_mkdir:
4486             LOP(OP_MKDIR,XTERM);
4487
4488         case KEY_msgctl:
4489             LOP(OP_MSGCTL,XTERM);
4490
4491         case KEY_msgget:
4492             LOP(OP_MSGGET,XTERM);
4493
4494         case KEY_msgrcv:
4495             LOP(OP_MSGRCV,XTERM);
4496
4497         case KEY_msgsnd:
4498             LOP(OP_MSGSND,XTERM);
4499
4500         case KEY_our:
4501         case KEY_my:
4502             PL_in_my = tmp;
4503             s = skipspace(s);
4504             if (isIDFIRST_lazy_if(s,UTF)) {
4505                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4506                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4507                     goto really_sub;
4508                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4509                 if (!PL_in_my_stash) {
4510                     char tmpbuf[1024];
4511                     PL_bufptr = s;
4512                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4513                     yyerror(tmpbuf);
4514                 }
4515             }
4516             yylval.ival = 1;
4517             OPERATOR(MY);
4518
4519         case KEY_next:
4520             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4521             LOOPX(OP_NEXT);
4522
4523         case KEY_ne:
4524             Eop(OP_SNE);
4525
4526         case KEY_no:
4527             if (PL_expect != XSTATE)
4528                 yyerror("\"no\" not allowed in expression");
4529             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4530             s = force_version(s);
4531             yylval.ival = 0;
4532             OPERATOR(USE);
4533
4534         case KEY_not:
4535             if (*s == '(' || (s = skipspace(s), *s == '('))
4536                 FUN1(OP_NOT);
4537             else
4538                 OPERATOR(NOTOP);
4539
4540         case KEY_open:
4541             s = skipspace(s);
4542             if (isIDFIRST_lazy_if(s,UTF)) {
4543                 char *t;
4544                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4545                 t = skipspace(d);
4546                 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4547                     Perl_warner(aTHX_ WARN_PRECEDENCE,
4548                            "Precedence problem: open %.*s should be open(%.*s)",
4549                             d-s,s, d-s,s);
4550             }
4551             LOP(OP_OPEN,XTERM);
4552
4553         case KEY_or:
4554             yylval.ival = OP_OR;
4555             OPERATOR(OROP);
4556
4557         case KEY_ord:
4558             UNI(OP_ORD);
4559
4560         case KEY_oct:
4561             UNI(OP_OCT);
4562
4563         case KEY_opendir:
4564             LOP(OP_OPEN_DIR,XTERM);
4565
4566         case KEY_print:
4567             checkcomma(s,PL_tokenbuf,"filehandle");
4568             LOP(OP_PRINT,XREF);
4569
4570         case KEY_printf:
4571             checkcomma(s,PL_tokenbuf,"filehandle");
4572             LOP(OP_PRTF,XREF);
4573
4574         case KEY_prototype:
4575             UNI(OP_PROTOTYPE);
4576
4577         case KEY_push:
4578             LOP(OP_PUSH,XTERM);
4579
4580         case KEY_pop:
4581             UNI(OP_POP);
4582
4583         case KEY_pos:
4584             UNI(OP_POS);
4585         
4586         case KEY_pack:
4587             LOP(OP_PACK,XTERM);
4588
4589         case KEY_package:
4590             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4591             OPERATOR(PACKAGE);
4592
4593         case KEY_pipe:
4594             LOP(OP_PIPE_OP,XTERM);
4595
4596         case KEY_q:
4597             s = scan_str(s,FALSE,FALSE);
4598             if (!s)
4599                 missingterm((char*)0);
4600             yylval.ival = OP_CONST;
4601             TERM(sublex_start());
4602
4603         case KEY_quotemeta:
4604             UNI(OP_QUOTEMETA);
4605
4606         case KEY_qw:
4607             s = scan_str(s,FALSE,FALSE);
4608             if (!s)
4609                 missingterm((char*)0);
4610             force_next(')');
4611             if (SvCUR(PL_lex_stuff)) {
4612                 OP *words = Nullop;
4613                 int warned = 0;
4614                 d = SvPV_force(PL_lex_stuff, len);
4615                 while (len) {
4616                     SV *sv;
4617                     for (; isSPACE(*d) && len; --len, ++d) ;
4618                     if (len) {
4619                         char *b = d;
4620                         if (!warned && ckWARN(WARN_QW)) {
4621                             for (; !isSPACE(*d) && len; --len, ++d) {
4622                                 if (*d == ',') {
4623                                     Perl_warner(aTHX_ WARN_QW,
4624                                         "Possible attempt to separate words with commas");
4625                                     ++warned;
4626                                 }
4627                                 else if (*d == '#') {
4628                                     Perl_warner(aTHX_ WARN_QW,
4629                                         "Possible attempt to put comments in qw() list");
4630                                     ++warned;
4631                                 }
4632                             }
4633                         }
4634                         else {
4635                             for (; !isSPACE(*d) && len; --len, ++d) ;
4636                         }
4637                         sv = newSVpvn(b, d-b);
4638                         if (DO_UTF8(PL_lex_stuff))
4639                             SvUTF8_on(sv);
4640                         words = append_elem(OP_LIST, words,
4641                                             newSVOP(OP_CONST, 0, tokeq(sv)));
4642                     }
4643                 }
4644                 if (words) {
4645                     PL_nextval[PL_nexttoke].opval = words;
4646                     force_next(THING);
4647                 }
4648             }
4649             if (PL_lex_stuff) {
4650                 SvREFCNT_dec(PL_lex_stuff);
4651                 PL_lex_stuff = Nullsv;
4652             }
4653             PL_expect = XTERM;
4654             TOKEN('(');
4655
4656         case KEY_qq:
4657             s = scan_str(s,FALSE,FALSE);
4658             if (!s)
4659                 missingterm((char*)0);
4660             yylval.ival = OP_STRINGIFY;
4661             if (SvIVX(PL_lex_stuff) == '\'')
4662                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
4663             TERM(sublex_start());
4664
4665         case KEY_qr:
4666             s = scan_pat(s,OP_QR);
4667             TERM(sublex_start());
4668
4669         case KEY_qx:
4670             s = scan_str(s,FALSE,FALSE);
4671             if (!s)
4672                 missingterm((char*)0);
4673             yylval.ival = OP_BACKTICK;
4674             set_csh();
4675             TERM(sublex_start());
4676
4677         case KEY_return:
4678             OLDLOP(OP_RETURN);
4679
4680         case KEY_require:
4681             s = skipspace(s);
4682             if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
4683                 s = force_version(s);
4684             }
4685             else {
4686                 *PL_tokenbuf = '\0';
4687                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4688                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4689                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4690                 else if (*s == '<')
4691                     yyerror("<> should be quotes");
4692             }
4693             UNI(OP_REQUIRE);
4694
4695         case KEY_reset:
4696             UNI(OP_RESET);
4697
4698         case KEY_redo:
4699             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4700             LOOPX(OP_REDO);
4701
4702         case KEY_rename:
4703             LOP(OP_RENAME,XTERM);
4704
4705         case KEY_rand:
4706             UNI(OP_RAND);
4707
4708         case KEY_rmdir:
4709             UNI(OP_RMDIR);
4710
4711         case KEY_rindex:
4712             LOP(OP_RINDEX,XTERM);
4713
4714         case KEY_read:
4715             LOP(OP_READ,XTERM);
4716
4717         case KEY_readdir:
4718             UNI(OP_READDIR);
4719
4720         case KEY_readline:
4721             set_csh();
4722             UNI(OP_READLINE);
4723
4724         case KEY_readpipe:
4725             set_csh();
4726             UNI(OP_BACKTICK);
4727
4728         case KEY_rewinddir:
4729             UNI(OP_REWINDDIR);
4730
4731         case KEY_recv:
4732             LOP(OP_RECV,XTERM);
4733
4734         case KEY_reverse:
4735             LOP(OP_REVERSE,XTERM);
4736
4737         case KEY_readlink:
4738             UNI(OP_READLINK);
4739
4740         case KEY_ref:
4741             UNI(OP_REF);
4742
4743         case KEY_s:
4744             s = scan_subst(s);
4745             if (yylval.opval)
4746                 TERM(sublex_start());
4747             else
4748                 TOKEN(1);       /* force error */
4749
4750         case KEY_chomp:
4751             UNI(OP_CHOMP);
4752         
4753         case KEY_scalar:
4754             UNI(OP_SCALAR);
4755
4756         case KEY_select:
4757             LOP(OP_SELECT,XTERM);
4758
4759         case KEY_seek:
4760             LOP(OP_SEEK,XTERM);
4761
4762         case KEY_semctl:
4763             LOP(OP_SEMCTL,XTERM);
4764
4765         case KEY_semget:
4766             LOP(OP_SEMGET,XTERM);
4767
4768         case KEY_semop:
4769             LOP(OP_SEMOP,XTERM);
4770
4771         case KEY_send:
4772             LOP(OP_SEND,XTERM);
4773
4774         case KEY_setpgrp:
4775             LOP(OP_SETPGRP,XTERM);
4776
4777         case KEY_setpriority:
4778             LOP(OP_SETPRIORITY,XTERM);
4779
4780         case KEY_sethostent:
4781             UNI(OP_SHOSTENT);
4782
4783         case KEY_setnetent:
4784             UNI(OP_SNETENT);
4785
4786         case KEY_setservent:
4787             UNI(OP_SSERVENT);
4788
4789         case KEY_setprotoent:
4790             UNI(OP_SPROTOENT);
4791
4792         case KEY_setpwent:
4793             FUN0(OP_SPWENT);
4794
4795         case KEY_setgrent:
4796             FUN0(OP_SGRENT);
4797
4798         case KEY_seekdir:
4799             LOP(OP_SEEKDIR,XTERM);
4800
4801         case KEY_setsockopt:
4802             LOP(OP_SSOCKOPT,XTERM);
4803
4804         case KEY_shift:
4805             UNI(OP_SHIFT);
4806
4807         case KEY_shmctl:
4808             LOP(OP_SHMCTL,XTERM);
4809
4810         case KEY_shmget:
4811             LOP(OP_SHMGET,XTERM);
4812
4813         case KEY_shmread:
4814             LOP(OP_SHMREAD,XTERM);
4815
4816         case KEY_shmwrite:
4817             LOP(OP_SHMWRITE,XTERM);
4818
4819         case KEY_shutdown:
4820             LOP(OP_SHUTDOWN,XTERM);
4821
4822         case KEY_sin:
4823             UNI(OP_SIN);
4824
4825         case KEY_sleep:
4826             UNI(OP_SLEEP);
4827
4828         case KEY_socket:
4829             LOP(OP_SOCKET,XTERM);
4830
4831         case KEY_socketpair:
4832             LOP(OP_SOCKPAIR,XTERM);
4833
4834         case KEY_sort:
4835             checkcomma(s,PL_tokenbuf,"subroutine name");
4836             s = skipspace(s);
4837             if (*s == ';' || *s == ')')         /* probably a close */
4838                 Perl_croak(aTHX_ "sort is now a reserved word");
4839             PL_expect = XTERM;
4840             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4841             LOP(OP_SORT,XREF);
4842
4843         case KEY_split:
4844             LOP(OP_SPLIT,XTERM);
4845
4846         case KEY_sprintf:
4847             LOP(OP_SPRINTF,XTERM);
4848
4849         case KEY_splice:
4850             LOP(OP_SPLICE,XTERM);
4851
4852         case KEY_sqrt:
4853             UNI(OP_SQRT);
4854
4855         case KEY_srand:
4856             UNI(OP_SRAND);
4857
4858         case KEY_stat:
4859             UNI(OP_STAT);
4860
4861         case KEY_study:
4862             UNI(OP_STUDY);
4863
4864         case KEY_substr:
4865             LOP(OP_SUBSTR,XTERM);
4866
4867         case KEY_format:
4868         case KEY_sub:
4869           really_sub:
4870             {
4871                 char tmpbuf[sizeof PL_tokenbuf];
4872                 SSize_t tboffset = 0;
4873                 expectation attrful;
4874                 bool have_name, have_proto;
4875                 int key = tmp;
4876
4877                 s = skipspace(s);
4878
4879                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4880                     (*s == ':' && s[1] == ':'))
4881                 {
4882                     PL_expect = XBLOCK;
4883                     attrful = XATTRBLOCK;
4884                     /* remember buffer pos'n for later force_word */
4885                     tboffset = s - PL_oldbufptr;
4886                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4887                     if (strchr(tmpbuf, ':'))
4888                         sv_setpv(PL_subname, tmpbuf);
4889                     else {
4890                         sv_setsv(PL_subname,PL_curstname);
4891                         sv_catpvn(PL_subname,"::",2);
4892                         sv_catpvn(PL_subname,tmpbuf,len);
4893                     }
4894                     s = skipspace(d);
4895                     have_name = TRUE;
4896                 }
4897                 else {
4898                     if (key == KEY_my)
4899                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
4900                     PL_expect = XTERMBLOCK;
4901                     attrful = XATTRTERM;
4902                     sv_setpv(PL_subname,"?");
4903                     have_name = FALSE;
4904                 }
4905
4906                 if (key == KEY_format) {
4907                     if (*s == '=')
4908                         PL_lex_formbrack = PL_lex_brackets + 1;
4909                     if (have_name)
4910                         (void) force_word(PL_oldbufptr + tboffset, WORD,
4911                                           FALSE, TRUE, TRUE);
4912                     OPERATOR(FORMAT);
4913                 }
4914
4915                 /* Look for a prototype */
4916                 if (*s == '(') {
4917                     char *p;
4918
4919                     s = scan_str(s,FALSE,FALSE);
4920                     if (!s)
4921                         Perl_croak(aTHX_ "Prototype not terminated");
4922                     /* strip spaces */
4923                     d = SvPVX(PL_lex_stuff);
4924                     tmp = 0;
4925                     for (p = d; *p; ++p) {
4926                         if (!isSPACE(*p))
4927                             d[tmp++] = *p;
4928                     }
4929                     d[tmp] = '\0';
4930                     SvCUR(PL_lex_stuff) = tmp;
4931                     have_proto = TRUE;
4932
4933                     s = skipspace(s);
4934                 }
4935                 else
4936                     have_proto = FALSE;
4937
4938                 if (*s == ':' && s[1] != ':')
4939                     PL_expect = attrful;
4940
4941                 if (have_proto) {
4942                     PL_nextval[PL_nexttoke].opval =
4943                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4944                     PL_lex_stuff = Nullsv;
4945                     force_next(THING);
4946                 }
4947                 if (!have_name) {
4948                     sv_setpv(PL_subname,"__ANON__");
4949                     TOKEN(ANONSUB);
4950                 }
4951                 (void) force_word(PL_oldbufptr + tboffset, WORD,
4952                                   FALSE, TRUE, TRUE);
4953                 if (key == KEY_my)
4954                     TOKEN(MYSUB);
4955                 TOKEN(SUB);
4956             }
4957
4958         case KEY_system:
4959             set_csh();
4960             LOP(OP_SYSTEM,XREF);
4961
4962         case KEY_symlink:
4963             LOP(OP_SYMLINK,XTERM);
4964
4965         case KEY_syscall:
4966             LOP(OP_SYSCALL,XTERM);
4967
4968         case KEY_sysopen:
4969             LOP(OP_SYSOPEN,XTERM);
4970
4971         case KEY_sysseek:
4972             LOP(OP_SYSSEEK,XTERM);
4973
4974         case KEY_sysread:
4975             LOP(OP_SYSREAD,XTERM);
4976
4977         case KEY_syswrite:
4978             LOP(OP_SYSWRITE,XTERM);
4979
4980         case KEY_tr:
4981             s = scan_trans(s);
4982             TERM(sublex_start());
4983
4984         case KEY_tell:
4985             UNI(OP_TELL);
4986
4987         case KEY_telldir:
4988             UNI(OP_TELLDIR);
4989
4990         case KEY_tie:
4991             LOP(OP_TIE,XTERM);
4992
4993         case KEY_tied:
4994             UNI(OP_TIED);
4995
4996         case KEY_time:
4997             FUN0(OP_TIME);
4998
4999         case KEY_times:
5000             FUN0(OP_TMS);
5001
5002         case KEY_truncate:
5003             LOP(OP_TRUNCATE,XTERM);
5004
5005         case KEY_uc:
5006             UNI(OP_UC);
5007
5008         case KEY_ucfirst:
5009             UNI(OP_UCFIRST);
5010
5011         case KEY_untie:
5012             UNI(OP_UNTIE);
5013
5014         case KEY_until:
5015             yylval.ival = CopLINE(PL_curcop);
5016             OPERATOR(UNTIL);
5017
5018         case KEY_unless:
5019             yylval.ival = CopLINE(PL_curcop);
5020             OPERATOR(UNLESS);
5021
5022         case KEY_unlink:
5023             LOP(OP_UNLINK,XTERM);
5024
5025         case KEY_undef:
5026             UNI(OP_UNDEF);
5027
5028         case KEY_unpack:
5029             LOP(OP_UNPACK,XTERM);
5030
5031         case KEY_utime:
5032             LOP(OP_UTIME,XTERM);
5033
5034         case KEY_umask:
5035             UNI(OP_UMASK);
5036
5037         case KEY_unshift:
5038             LOP(OP_UNSHIFT,XTERM);
5039
5040         case KEY_use:
5041             if (PL_expect != XSTATE)
5042                 yyerror("\"use\" not allowed in expression");
5043             s = skipspace(s);
5044             if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5045                 s = force_version(s);
5046                 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5047                     PL_nextval[PL_nexttoke].opval = Nullop;
5048                     force_next(WORD);
5049                 }
5050             }
5051             else {
5052                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5053                 s = force_version(s);
5054             }
5055             yylval.ival = 1;
5056             OPERATOR(USE);
5057
5058         case KEY_values:
5059             UNI(OP_VALUES);
5060
5061         case KEY_vec:
5062             LOP(OP_VEC,XTERM);
5063
5064         case KEY_while:
5065             yylval.ival = CopLINE(PL_curcop);
5066             OPERATOR(WHILE);
5067
5068         case KEY_warn:
5069             PL_hints |= HINT_BLOCK_SCOPE;
5070             LOP(OP_WARN,XTERM);
5071
5072         case KEY_wait:
5073             FUN0(OP_WAIT);
5074
5075         case KEY_waitpid:
5076             LOP(OP_WAITPID,XTERM);
5077
5078         case KEY_wantarray:
5079             FUN0(OP_WANTARRAY);
5080
5081         case KEY_write:
5082 #ifdef EBCDIC
5083         {
5084             static char ctl_l[2];
5085
5086             if (ctl_l[0] == '\0')
5087                 ctl_l[0] = toCTRL('L');
5088             gv_fetchpv(ctl_l,TRUE, SVt_PV);
5089         }
5090 #else
5091             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
5092 #endif
5093             UNI(OP_ENTERWRITE);
5094
5095         case KEY_x:
5096             if (PL_expect == XOPERATOR)
5097                 Mop(OP_REPEAT);
5098             check_uni();
5099             goto just_a_word;
5100
5101         case KEY_xor:
5102             yylval.ival = OP_XOR;
5103             OPERATOR(OROP);
5104
5105         case KEY_y:
5106             s = scan_trans(s);
5107             TERM(sublex_start());
5108         }
5109     }}
5110 }
5111 #ifdef __SC__
5112 #pragma segment Main
5113 #endif
5114
5115 static int
5116 S_pending_ident(pTHX)
5117 {
5118     register char *d;
5119     register I32 tmp;
5120     /* pit holds the identifier we read and pending_ident is reset */
5121     char pit = PL_pending_ident;
5122     PL_pending_ident = 0;
5123
5124     DEBUG_T({ PerlIO_printf(Perl_debug_log,
5125           "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5126
5127     /* if we're in a my(), we can't allow dynamics here.
5128        $foo'bar has already been turned into $foo::bar, so
5129        just check for colons.
5130
5131        if it's a legal name, the OP is a PADANY.
5132     */
5133     if (PL_in_my) {
5134         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
5135             if (strchr(PL_tokenbuf,':'))
5136                 yyerror(Perl_form(aTHX_ "No package name allowed for "
5137                                   "variable %s in \"our\"",
5138                                   PL_tokenbuf));
5139             tmp = pad_allocmy(PL_tokenbuf);
5140         }
5141         else {
5142             if (strchr(PL_tokenbuf,':'))
5143                 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5144
5145             yylval.opval = newOP(OP_PADANY, 0);
5146             yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
5147             return PRIVATEREF;
5148         }
5149     }
5150
5151     /*
5152        build the ops for accesses to a my() variable.
5153
5154        Deny my($a) or my($b) in a sort block, *if* $a or $b is
5155        then used in a comparison.  This catches most, but not
5156        all cases.  For instance, it catches
5157            sort { my($a); $a <=> $b }
5158        but not
5159            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5160        (although why you'd do that is anyone's guess).
5161     */
5162
5163     if (!strchr(PL_tokenbuf,':')) {
5164 #ifdef USE_THREADS
5165         /* Check for single character per-thread SVs */
5166         if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
5167             && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
5168             && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
5169         {
5170             yylval.opval = newOP(OP_THREADSV, 0);
5171             yylval.opval->op_targ = tmp;
5172             return PRIVATEREF;
5173         }
5174 #endif /* USE_THREADS */
5175         if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
5176             SV *namesv = AvARRAY(PL_comppad_name)[tmp];
5177             /* might be an "our" variable" */
5178             if (SvFLAGS(namesv) & SVpad_OUR) {
5179                 /* build ops for a bareword */
5180                 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
5181                 sv_catpvn(sym, "::", 2);
5182                 sv_catpv(sym, PL_tokenbuf+1);
5183                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5184                 yylval.opval->op_private = OPpCONST_ENTERED;
5185                 gv_fetchpv(SvPVX(sym),
5186                     (PL_in_eval
5187                         ? (GV_ADDMULTI | GV_ADDINEVAL)
5188                         : TRUE
5189                     ),
5190                     ((PL_tokenbuf[0] == '$') ? SVt_PV
5191                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5192                      : SVt_PVHV));
5193                 return WORD;
5194             }
5195
5196             /* if it's a sort block and they're naming $a or $b */
5197             if (PL_last_lop_op == OP_SORT &&
5198                 PL_tokenbuf[0] == '$' &&
5199                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5200                 && !PL_tokenbuf[2])
5201             {
5202                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5203                      d < PL_bufend && *d != '\n';
5204                      d++)
5205                 {
5206                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5207                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5208                               PL_tokenbuf);
5209                     }
5210                 }
5211             }
5212
5213             yylval.opval = newOP(OP_PADANY, 0);
5214             yylval.opval->op_targ = tmp;
5215             return PRIVATEREF;
5216         }
5217     }
5218
5219     /*
5220        Whine if they've said @foo in a doublequoted string,
5221        and @foo isn't a variable we can find in the symbol
5222        table.
5223     */
5224     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5225         GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5226         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5227              && ckWARN(WARN_AMBIGUOUS))
5228         {
5229             /* Downgraded from fatal to warning 20000522 mjd */
5230             Perl_warner(aTHX_ WARN_AMBIGUOUS,
5231                         "Possible unintended interpolation of %s in string",
5232                          PL_tokenbuf);
5233         }
5234     }
5235
5236     /* build ops for a bareword */
5237     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5238     yylval.opval->op_private = OPpCONST_ENTERED;
5239     gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5240                ((PL_tokenbuf[0] == '$') ? SVt_PV
5241                 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5242                 : SVt_PVHV));
5243     return WORD;
5244 }
5245
5246 I32
5247 Perl_keyword(pTHX_ register char *d, I32 len)
5248 {
5249     switch (*d) {
5250     case '_':
5251         if (d[1] == '_') {
5252             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
5253             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
5254             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
5255             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
5256             if (strEQ(d,"__END__"))             return KEY___END__;
5257         }
5258         break;
5259     case 'A':
5260         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
5261         break;
5262     case 'a':
5263         switch (len) {
5264         case 3:
5265             if (strEQ(d,"and"))                 return -KEY_and;
5266             if (strEQ(d,"abs"))                 return -KEY_abs;
5267             break;
5268         case 5:
5269             if (strEQ(d,"alarm"))               return -KEY_alarm;
5270             if (strEQ(d,"atan2"))               return -KEY_atan2;
5271             break;
5272         case 6:
5273             if (strEQ(d,"accept"))              return -KEY_accept;
5274             break;
5275         }
5276         break;
5277     case 'B':
5278         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
5279         break;
5280     case 'b':
5281         if (strEQ(d,"bless"))                   return -KEY_bless;
5282         if (strEQ(d,"bind"))                    return -KEY_bind;
5283         if (strEQ(d,"binmode"))                 return -KEY_binmode;
5284         break;
5285     case 'C':
5286         if (strEQ(d,"CORE"))                    return -KEY_CORE;
5287         if (strEQ(d,"CHECK"))                   return KEY_CHECK;
5288         break;
5289     case 'c':
5290         switch (len) {
5291         case 3:
5292             if (strEQ(d,"cmp"))                 return -KEY_cmp;
5293             if (strEQ(d,"chr"))                 return -KEY_chr;
5294             if (strEQ(d,"cos"))                 return -KEY_cos;
5295             break;
5296         case 4:
5297             if (strEQ(d,"chop"))                return -KEY_chop;
5298             break;
5299         case 5:
5300             if (strEQ(d,"close"))               return -KEY_close;
5301             if (strEQ(d,"chdir"))               return -KEY_chdir;
5302             if (strEQ(d,"chomp"))               return -KEY_chomp;
5303             if (strEQ(d,"chmod"))               return -KEY_chmod;
5304             if (strEQ(d,"chown"))               return -KEY_chown;
5305             if (strEQ(d,"crypt"))               return -KEY_crypt;
5306             break;
5307         case 6:
5308             if (strEQ(d,"chroot"))              return -KEY_chroot;
5309             if (strEQ(d,"caller"))              return -KEY_caller;
5310             break;
5311         case 7:
5312             if (strEQ(d,"connect"))             return -KEY_connect;
5313             break;
5314         case 8:
5315             if (strEQ(d,"closedir"))            return -KEY_closedir;
5316             if (strEQ(d,"continue"))            return -KEY_continue;
5317             break;
5318         }
5319         break;
5320     case 'D':
5321         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
5322         break;
5323     case 'd':
5324         switch (len) {
5325         case 2:
5326             if (strEQ(d,"do"))                  return KEY_do;
5327             break;
5328         case 3:
5329             if (strEQ(d,"die"))                 return -KEY_die;
5330             break;
5331         case 4:
5332             if (strEQ(d,"dump"))                return -KEY_dump;
5333             break;
5334         case 6:
5335             if (strEQ(d,"delete"))              return KEY_delete;
5336             break;
5337         case 7:
5338             if (strEQ(d,"defined"))             return KEY_defined;
5339             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
5340             break;
5341         case 8:
5342             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
5343             break;
5344         }
5345         break;
5346     case 'E':
5347         if (strEQ(d,"END"))                     return KEY_END;
5348         break;
5349     case 'e':
5350         switch (len) {
5351         case 2:
5352             if (strEQ(d,"eq"))                  return -KEY_eq;
5353             break;
5354         case 3:
5355             if (strEQ(d,"eof"))                 return -KEY_eof;
5356             if (strEQ(d,"exp"))                 return -KEY_exp;
5357             break;
5358         case 4:
5359             if (strEQ(d,"else"))                return KEY_else;
5360             if (strEQ(d,"exit"))                return -KEY_exit;
5361             if (strEQ(d,"eval"))                return KEY_eval;
5362             if (strEQ(d,"exec"))                return -KEY_exec;
5363            if (strEQ(d,"each"))                return -KEY_each;
5364             break;
5365         case 5:
5366             if (strEQ(d,"elsif"))               return KEY_elsif;
5367             break;
5368         case 6:
5369             if (strEQ(d,"exists"))              return KEY_exists;
5370             if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5371             break;
5372         case 8:
5373             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
5374             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
5375             break;
5376         case 9:
5377             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
5378             break;
5379         case 10:
5380             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
5381             if (strEQ(d,"endservent"))          return -KEY_endservent;
5382             break;
5383         case 11:
5384             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
5385             break;
5386         }
5387         break;
5388     case 'f':
5389         switch (len) {
5390         case 3:
5391             if (strEQ(d,"for"))                 return KEY_for;
5392             break;
5393         case 4:
5394             if (strEQ(d,"fork"))                return -KEY_fork;
5395             break;
5396         case 5:
5397             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
5398             if (strEQ(d,"flock"))               return -KEY_flock;
5399             break;
5400         case 6:
5401             if (strEQ(d,"format"))              return KEY_format;
5402             if (strEQ(d,"fileno"))              return -KEY_fileno;
5403             break;
5404         case 7:
5405             if (strEQ(d,"foreach"))             return KEY_foreach;
5406             break;
5407         case 8:
5408             if (strEQ(d,"formline"))            return -KEY_formline;
5409             break;
5410         }
5411         break;
5412     case 'g':
5413         if (strnEQ(d,"get",3)) {
5414             d += 3;
5415             if (*d == 'p') {
5416                 switch (len) {
5417                 case 7:
5418                     if (strEQ(d,"ppid"))        return -KEY_getppid;
5419                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
5420                     break;
5421                 case 8:
5422                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
5423                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
5424                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
5425                     break;
5426                 case 11:
5427                     if (strEQ(d,"peername"))    return -KEY_getpeername;
5428                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
5429                     if (strEQ(d,"priority"))    return -KEY_getpriority;
5430                     break;
5431                 case 14:
5432                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5433                     break;
5434                 case 16:
5435                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5436                     break;
5437                 }
5438             }
5439             else if (*d == 'h') {
5440                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
5441                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
5442                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
5443             }
5444             else if (*d == 'n') {
5445                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
5446                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
5447                 if (strEQ(d,"netent"))          return -KEY_getnetent;
5448             }
5449             else if (*d == 's') {
5450                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
5451                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
5452                 if (strEQ(d,"servent"))         return -KEY_getservent;
5453                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
5454                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
5455             }
5456             else if (*d == 'g') {
5457                 if (strEQ(d,"grent"))           return -KEY_getgrent;
5458                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
5459                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
5460             }
5461             else if (*d == 'l') {
5462                 if (strEQ(d,"login"))           return -KEY_getlogin;
5463             }
5464             else if (strEQ(d,"c"))              return -KEY_getc;
5465             break;
5466         }
5467         switch (len) {
5468         case 2:
5469             if (strEQ(d,"gt"))                  return -KEY_gt;
5470             if (strEQ(d,"ge"))                  return -KEY_ge;
5471             break;
5472         case 4:
5473             if (strEQ(d,"grep"))                return KEY_grep;
5474             if (strEQ(d,"goto"))                return KEY_goto;
5475             if (strEQ(d,"glob"))                return KEY_glob;
5476             break;
5477         case 6:
5478             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
5479             break;
5480         }
5481         break;
5482     case 'h':
5483         if (strEQ(d,"hex"))                     return -KEY_hex;
5484         break;
5485     case 'I':
5486         if (strEQ(d,"INIT"))                    return KEY_INIT;
5487         break;
5488     case 'i':
5489         switch (len) {
5490         case 2:
5491             if (strEQ(d,"if"))                  return KEY_if;
5492             break;
5493         case 3:
5494             if (strEQ(d,"int"))                 return -KEY_int;
5495             break;
5496         case 5:
5497             if (strEQ(d,"index"))               return -KEY_index;
5498             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
5499             break;
5500         }
5501         break;
5502     case 'j':
5503         if (strEQ(d,"join"))                    return -KEY_join;
5504         break;
5505     case 'k':
5506         if (len == 4) {
5507            if (strEQ(d,"keys"))                return -KEY_keys;
5508             if (strEQ(d,"kill"))                return -KEY_kill;
5509         }
5510         break;
5511     case 'l':
5512         switch (len) {
5513         case 2:
5514             if (strEQ(d,"lt"))                  return -KEY_lt;
5515             if (strEQ(d,"le"))                  return -KEY_le;
5516             if (strEQ(d,"lc"))                  return -KEY_lc;
5517             break;
5518         case 3:
5519             if (strEQ(d,"log"))                 return -KEY_log;
5520             break;
5521         case 4:
5522             if (strEQ(d,"last"))                return KEY_last;
5523             if (strEQ(d,"link"))                return -KEY_link;
5524             if (strEQ(d,"lock"))                return -KEY_lock;
5525             break;
5526         case 5:
5527             if (strEQ(d,"local"))               return KEY_local;
5528             if (strEQ(d,"lstat"))               return -KEY_lstat;
5529             break;
5530         case 6:
5531             if (strEQ(d,"length"))              return -KEY_length;
5532             if (strEQ(d,"listen"))              return -KEY_listen;
5533             break;
5534         case 7:
5535             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
5536             break;
5537         case 9:
5538             if (strEQ(d,"localtime"))           return -KEY_localtime;
5539             break;
5540         }
5541         break;
5542     case 'm':
5543         switch (len) {
5544         case 1:                                 return KEY_m;
5545         case 2:
5546             if (strEQ(d,"my"))                  return KEY_my;
5547             break;
5548         case 3:
5549             if (strEQ(d,"map"))                 return KEY_map;
5550             break;
5551         case 5:
5552             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
5553             break;
5554         case 6:
5555             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
5556             if (strEQ(d,"msgget"))              return -KEY_msgget;
5557             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
5558             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
5559             break;
5560         }
5561         break;
5562     case 'n':
5563         if (strEQ(d,"next"))                    return KEY_next;
5564         if (strEQ(d,"ne"))                      return -KEY_ne;
5565         if (strEQ(d,"not"))                     return -KEY_not;
5566         if (strEQ(d,"no"))                      return KEY_no;
5567         break;
5568     case 'o':
5569         switch (len) {
5570         case 2:
5571             if (strEQ(d,"or"))                  return -KEY_or;
5572             break;
5573         case 3:
5574             if (strEQ(d,"ord"))                 return -KEY_ord;
5575             if (strEQ(d,"oct"))                 return -KEY_oct;
5576             if (strEQ(d,"our"))                 return KEY_our;
5577             break;
5578         case 4:
5579             if (strEQ(d,"open"))                return -KEY_open;
5580             break;
5581         case 7:
5582             if (strEQ(d,"opendir"))             return -KEY_opendir;
5583             break;
5584         }
5585         break;
5586     case 'p':
5587         switch (len) {
5588         case 3:
5589            if (strEQ(d,"pop"))                 return -KEY_pop;
5590             if (strEQ(d,"pos"))                 return KEY_pos;
5591             break;
5592         case 4:
5593            if (strEQ(d,"push"))                return -KEY_push;
5594             if (strEQ(d,"pack"))                return -KEY_pack;
5595             if (strEQ(d,"pipe"))                return -KEY_pipe;
5596             break;
5597         case 5:
5598             if (strEQ(d,"print"))               return KEY_print;
5599             break;
5600         case 6:
5601             if (strEQ(d,"printf"))              return KEY_printf;
5602             break;
5603         case 7:
5604             if (strEQ(d,"package"))             return KEY_package;
5605             break;
5606         case 9:
5607             if (strEQ(d,"prototype"))           return KEY_prototype;
5608         }
5609         break;
5610     case 'q':
5611         if (len <= 2) {
5612             if (strEQ(d,"q"))                   return KEY_q;
5613             if (strEQ(d,"qr"))                  return KEY_qr;
5614             if (strEQ(d,"qq"))                  return KEY_qq;
5615             if (strEQ(d,"qw"))                  return KEY_qw;
5616             if (strEQ(d,"qx"))                  return KEY_qx;
5617         }
5618         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
5619         break;
5620     case 'r':
5621         switch (len) {
5622         case 3:
5623             if (strEQ(d,"ref"))                 return -KEY_ref;
5624             break;
5625         case 4:
5626             if (strEQ(d,"read"))                return -KEY_read;
5627             if (strEQ(d,"rand"))                return -KEY_rand;
5628             if (strEQ(d,"recv"))                return -KEY_recv;
5629             if (strEQ(d,"redo"))                return KEY_redo;
5630             break;
5631         case 5:
5632             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
5633             if (strEQ(d,"reset"))               return -KEY_reset;
5634             break;
5635         case 6:
5636             if (strEQ(d,"return"))              return KEY_return;
5637             if (strEQ(d,"rename"))              return -KEY_rename;
5638             if (strEQ(d,"rindex"))              return -KEY_rindex;
5639             break;
5640         case 7:
5641             if (strEQ(d,"require"))             return KEY_require;
5642             if (strEQ(d,"reverse"))             return -KEY_reverse;
5643             if (strEQ(d,"readdir"))             return -KEY_readdir;
5644             break;
5645         case 8:
5646             if (strEQ(d,"readlink"))            return -KEY_readlink;
5647             if (strEQ(d,"readline"))            return -KEY_readline;
5648             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
5649             break;
5650         case 9:
5651             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
5652             break;
5653         }
5654         break;
5655     case 's':
5656         switch (d[1]) {
5657         case 0:                                 return KEY_s;
5658         case 'c':
5659             if (strEQ(d,"scalar"))              return KEY_scalar;
5660             break;
5661         case 'e':
5662             switch (len) {
5663             case 4:
5664                 if (strEQ(d,"seek"))            return -KEY_seek;
5665                 if (strEQ(d,"send"))            return -KEY_send;
5666                 break;
5667             case 5:
5668                 if (strEQ(d,"semop"))           return -KEY_semop;
5669                 break;
5670             case 6:
5671                 if (strEQ(d,"select"))          return -KEY_select;
5672                 if (strEQ(d,"semctl"))          return -KEY_semctl;
5673                 if (strEQ(d,"semget"))          return -KEY_semget;
5674                 break;
5675             case 7:
5676                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
5677                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
5678                 break;
5679             case 8:
5680                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
5681                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
5682                 break;
5683             case 9:
5684                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
5685                 break;
5686             case 10:
5687                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
5688                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
5689                 if (strEQ(d,"setservent"))      return -KEY_setservent;
5690                 break;
5691             case 11:
5692                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
5693                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
5694                 break;
5695             }
5696             break;
5697         case 'h':
5698             switch (len) {
5699             case 5:
5700                if (strEQ(d,"shift"))           return -KEY_shift;
5701                 break;
5702             case 6:
5703                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
5704                 if (strEQ(d,"shmget"))          return -KEY_shmget;
5705                 break;
5706             case 7:
5707                 if (strEQ(d,"shmread"))         return -KEY_shmread;
5708                 break;
5709             case 8:
5710                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
5711                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
5712                 break;
5713             }
5714             break;
5715         case 'i':
5716             if (strEQ(d,"sin"))                 return -KEY_sin;
5717             break;
5718         case 'l':
5719             if (strEQ(d,"sleep"))               return -KEY_sleep;
5720             break;
5721         case 'o':
5722             if (strEQ(d,"sort"))                return KEY_sort;
5723             if (strEQ(d,"socket"))              return -KEY_socket;
5724             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
5725             break;
5726         case 'p':
5727             if (strEQ(d,"split"))               return KEY_split;
5728             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
5729            if (strEQ(d,"splice"))              return -KEY_splice;
5730             break;
5731         case 'q':
5732             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
5733             break;
5734         case 'r':
5735             if (strEQ(d,"srand"))               return -KEY_srand;
5736             break;
5737         case 't':
5738             if (strEQ(d,"stat"))                return -KEY_stat;
5739             if (strEQ(d,"study"))               return KEY_study;
5740             break;
5741         case 'u':
5742             if (strEQ(d,"substr"))              return -KEY_substr;
5743             if (strEQ(d,"sub"))                 return KEY_sub;
5744             break;
5745         case 'y':
5746             switch (len) {
5747             case 6:
5748                 if (strEQ(d,"system"))          return -KEY_system;
5749                 break;
5750             case 7:
5751                 if (strEQ(d,"symlink"))         return -KEY_symlink;
5752                 if (strEQ(d,"syscall"))         return -KEY_syscall;
5753                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
5754                 if (strEQ(d,"sysread"))         return -KEY_sysread;
5755                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
5756                 break;
5757             case 8:
5758                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
5759                 break;
5760             }
5761             break;
5762         }
5763         break;
5764     case 't':
5765         switch (len) {
5766         case 2:
5767             if (strEQ(d,"tr"))                  return KEY_tr;
5768             break;
5769         case 3:
5770             if (strEQ(d,"tie"))                 return KEY_tie;
5771             break;
5772         case 4:
5773             if (strEQ(d,"tell"))                return -KEY_tell;
5774             if (strEQ(d,"tied"))                return KEY_tied;
5775             if (strEQ(d,"time"))                return -KEY_time;
5776             break;
5777         case 5:
5778             if (strEQ(d,"times"))               return -KEY_times;
5779             break;
5780         case 7:
5781             if (strEQ(d,"telldir"))             return -KEY_telldir;
5782             break;
5783         case 8:
5784             if (strEQ(d,"truncate"))            return -KEY_truncate;
5785             break;
5786         }
5787         break;
5788     case 'u':
5789         switch (len) {
5790         case 2:
5791             if (strEQ(d,"uc"))                  return -KEY_uc;
5792             break;
5793         case 3:
5794             if (strEQ(d,"use"))                 return KEY_use;
5795             break;
5796         case 5:
5797             if (strEQ(d,"undef"))               return KEY_undef;
5798             if (strEQ(d,"until"))               return KEY_until;
5799             if (strEQ(d,"untie"))               return KEY_untie;
5800             if (strEQ(d,"utime"))               return -KEY_utime;
5801             if (strEQ(d,"umask"))               return -KEY_umask;
5802             break;
5803         case 6:
5804             if (strEQ(d,"unless"))              return KEY_unless;
5805             if (strEQ(d,"unpack"))              return -KEY_unpack;
5806             if (strEQ(d,"unlink"))              return -KEY_unlink;
5807             break;
5808         case 7:
5809            if (strEQ(d,"unshift"))             return -KEY_unshift;
5810             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
5811             break;
5812         }
5813         break;
5814     case 'v':
5815         if (strEQ(d,"values"))                  return -KEY_values;
5816         if (strEQ(d,"vec"))                     return -KEY_vec;
5817         break;
5818     case 'w':
5819         switch (len) {
5820         case 4:
5821             if (strEQ(d,"warn"))                return -KEY_warn;
5822             if (strEQ(d,"wait"))                return -KEY_wait;
5823             break;
5824         case 5:
5825             if (strEQ(d,"while"))               return KEY_while;
5826             if (strEQ(d,"write"))               return -KEY_write;
5827             break;
5828         case 7:
5829             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
5830             break;
5831         case 9:
5832             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
5833             break;
5834         }
5835         break;
5836     case 'x':
5837         if (len == 1)                           return -KEY_x;
5838         if (strEQ(d,"xor"))                     return -KEY_xor;
5839         break;
5840     case 'y':
5841         if (len == 1)                           return KEY_y;
5842         break;
5843     case 'z':
5844         break;
5845     }
5846     return 0;
5847 }
5848
5849 STATIC void
5850 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5851 {
5852     char *w;
5853
5854     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
5855         if (ckWARN(WARN_SYNTAX)) {
5856             int level = 1;
5857             for (w = s+2; *w && level; w++) {
5858                 if (*w == '(')
5859                     ++level;
5860                 else if (*w == ')')
5861                     --level;
5862             }
5863             if (*w)
5864                 for (; *w && isSPACE(*w); w++) ;
5865             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
5866                 Perl_warner(aTHX_ WARN_SYNTAX,
5867                             "%s (...) interpreted as function",name);
5868         }
5869     }
5870     while (s < PL_bufend && isSPACE(*s))
5871         s++;
5872     if (*s == '(')
5873         s++;
5874     while (s < PL_bufend && isSPACE(*s))
5875         s++;
5876     if (isIDFIRST_lazy_if(s,UTF)) {
5877         w = s++;
5878         while (isALNUM_lazy_if(s,UTF))
5879             s++;
5880         while (s < PL_bufend && isSPACE(*s))
5881             s++;
5882         if (*s == ',') {
5883             int kw;
5884             *s = '\0';
5885             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
5886             *s = ',';
5887             if (kw)
5888                 return;
5889             Perl_croak(aTHX_ "No comma allowed after %s", what);
5890         }
5891     }
5892 }
5893
5894 /* Either returns sv, or mortalizes sv and returns a new SV*.
5895    Best used as sv=new_constant(..., sv, ...).
5896    If s, pv are NULL, calls subroutine with one argument,
5897    and type is used with error messages only. */
5898
5899 STATIC SV *
5900 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
5901                const char *type)
5902 {
5903     dSP;
5904     HV *table = GvHV(PL_hintgv);                 /* ^H */
5905     SV *res;
5906     SV **cvp;
5907     SV *cv, *typesv;
5908     const char *why1, *why2, *why3;
5909
5910     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5911         SV *msg;
5912         
5913         why2 = strEQ(key,"charnames")
5914                ? "(possibly a missing \"use charnames ...\")"
5915                : "";
5916         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
5917                             (type ? type: "undef"), why2);
5918
5919         /* This is convoluted and evil ("goto considered harmful")
5920          * but I do not understand the intricacies of all the different
5921          * failure modes of %^H in here.  The goal here is to make
5922          * the most probable error message user-friendly. --jhi */
5923
5924         goto msgdone;
5925
5926     report:
5927         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
5928                             (type ? type: "undef"), why1, why2, why3);
5929     msgdone:
5930         yyerror(SvPVX(msg));
5931         SvREFCNT_dec(msg);
5932         return sv;
5933     }
5934     cvp = hv_fetch(table, key, strlen(key), FALSE);
5935     if (!cvp || !SvOK(*cvp)) {
5936         why1 = "$^H{";
5937         why2 = key;
5938         why3 = "} is not defined";
5939         goto report;
5940     }
5941     sv_2mortal(sv);                     /* Parent created it permanently */
5942     cv = *cvp;
5943     if (!pv && s)
5944         pv = sv_2mortal(newSVpvn(s, len));
5945     if (type && pv)
5946         typesv = sv_2mortal(newSVpv(type, 0));
5947     else
5948         typesv = &PL_sv_undef;
5949
5950     PUSHSTACKi(PERLSI_OVERLOAD);
5951     ENTER ;
5952     SAVETMPS;
5953
5954     PUSHMARK(SP) ;
5955     EXTEND(sp, 3);
5956     if (pv)
5957         PUSHs(pv);
5958     PUSHs(sv);
5959     if (pv)
5960         PUSHs(typesv);
5961     PUTBACK;
5962     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
5963
5964     SPAGAIN ;
5965
5966     /* Check the eval first */
5967     if (!PL_in_eval && SvTRUE(ERRSV)) {
5968         STRLEN n_a;
5969         sv_catpv(ERRSV, "Propagated");
5970         yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
5971         (void)POPs;
5972         res = SvREFCNT_inc(sv);
5973     }
5974     else {
5975         res = POPs;
5976         (void)SvREFCNT_inc(res);
5977     }
5978
5979     PUTBACK ;
5980     FREETMPS ;
5981     LEAVE ;
5982     POPSTACK;
5983
5984     if (!SvOK(res)) {
5985         why1 = "Call to &{$^H{";
5986         why2 = key;
5987         why3 = "}} did not return a defined value";
5988         sv = res;
5989         goto report;
5990     }
5991
5992     return res;
5993 }
5994
5995 STATIC char *
5996 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5997 {
5998     register char *d = dest;
5999     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
6000     for (;;) {
6001         if (d >= e)
6002             Perl_croak(aTHX_ ident_too_long);
6003         if (isALNUM(*s))        /* UTF handled below */
6004             *d++ = *s++;
6005         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6006             *d++ = ':';
6007             *d++ = ':';
6008             s++;
6009         }
6010         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6011             *d++ = *s++;
6012             *d++ = *s++;
6013         }
6014         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6015             char *t = s + UTF8SKIP(s);
6016             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6017                 t += UTF8SKIP(t);
6018             if (d + (t - s) > e)
6019                 Perl_croak(aTHX_ ident_too_long);
6020             Copy(s, d, t - s, char);
6021             d += t - s;
6022             s = t;
6023         }
6024         else {
6025             *d = '\0';
6026             *slp = d - dest;
6027             return s;
6028         }
6029     }
6030 }
6031
6032 STATIC char *
6033 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6034 {
6035     register char *d;
6036     register char *e;
6037     char *bracket = 0;
6038     char funny = *s++;
6039
6040     if (isSPACE(*s))
6041         s = skipspace(s);
6042     d = dest;
6043     e = d + destlen - 3;        /* two-character token, ending NUL */
6044     if (isDIGIT(*s)) {
6045         while (isDIGIT(*s)) {
6046             if (d >= e)
6047                 Perl_croak(aTHX_ ident_too_long);
6048             *d++ = *s++;
6049         }
6050     }
6051     else {
6052         for (;;) {
6053             if (d >= e)
6054                 Perl_croak(aTHX_ ident_too_long);
6055             if (isALNUM(*s))    /* UTF handled below */
6056                 *d++ = *s++;
6057             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6058                 *d++ = ':';
6059                 *d++ = ':';
6060                 s++;
6061             }
6062             else if (*s == ':' && s[1] == ':') {
6063                 *d++ = *s++;
6064                 *d++ = *s++;
6065             }
6066             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6067                 char *t = s + UTF8SKIP(s);
6068                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6069                     t += UTF8SKIP(t);
6070                 if (d + (t - s) > e)
6071                     Perl_croak(aTHX_ ident_too_long);
6072                 Copy(s, d, t - s, char);
6073                 d += t - s;
6074                 s = t;
6075             }
6076             else
6077                 break;
6078         }
6079     }
6080     *d = '\0';
6081     d = dest;
6082     if (*d) {
6083         if (PL_lex_state != LEX_NORMAL)
6084             PL_lex_state = LEX_INTERPENDMAYBE;
6085         return s;
6086     }
6087     if (*s == '$' && s[1] &&
6088         (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6089     {
6090         return s;
6091     }
6092     if (*s == '{') {
6093         bracket = s;
6094         s++;
6095     }
6096     else if (ck_uni)
6097         check_uni();
6098     if (s < send)
6099         *d = *s++;
6100     d[1] = '\0';
6101     if (*d == '^' && *s && isCONTROLVAR(*s)) {
6102         *d = toCTRL(*s);
6103         s++;
6104     }
6105     if (bracket) {
6106         if (isSPACE(s[-1])) {
6107             while (s < send) {
6108                 char ch = *s++;
6109                 if (!SPACE_OR_TAB(ch)) {
6110                     *d = ch;
6111                     break;
6112                 }
6113             }
6114         }
6115         if (isIDFIRST_lazy_if(d,UTF)) {
6116             d++;
6117             if (UTF) {
6118                 e = s;
6119                 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6120                     e += UTF8SKIP(e);
6121                     while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6122                         e += UTF8SKIP(e);
6123                 }
6124                 Copy(s, d, e - s, char);
6125                 d += e - s;
6126                 s = e;
6127             }
6128             else {
6129                 while ((isALNUM(*s) || *s == ':') && d < e)
6130                     *d++ = *s++;
6131                 if (d >= e)
6132                     Perl_croak(aTHX_ ident_too_long);
6133             }
6134             *d = '\0';
6135             while (s < send && SPACE_OR_TAB(*s)) s++;
6136             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6137                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6138                     const char *brack = *s == '[' ? "[...]" : "{...}";
6139                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
6140                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6141                         funny, dest, brack, funny, dest, brack);
6142                 }
6143                 bracket++;
6144                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6145                 return s;
6146             }
6147         }
6148         /* Handle extended ${^Foo} variables
6149          * 1999-02-27 mjd-perl-patch@plover.com */
6150         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6151                  && isALNUM(*s))
6152         {
6153             d++;
6154             while (isALNUM(*s) && d < e) {
6155                 *d++ = *s++;
6156             }
6157             if (d >= e)
6158                 Perl_croak(aTHX_ ident_too_long);
6159             *d = '\0';
6160         }
6161         if (*s == '}') {
6162             s++;
6163             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
6164                 PL_lex_state = LEX_INTERPEND;
6165             if (funny == '#')
6166                 funny = '@';
6167             if (PL_lex_state == LEX_NORMAL) {
6168                 if (ckWARN(WARN_AMBIGUOUS) &&
6169                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6170                 {
6171                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
6172                         "Ambiguous use of %c{%s} resolved to %c%s",
6173                         funny, dest, funny, dest);
6174                 }
6175             }
6176         }
6177         else {
6178             s = bracket;                /* let the parser handle it */
6179             *dest = '\0';
6180         }
6181     }
6182     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6183         PL_lex_state = LEX_INTERPEND;
6184     return s;
6185 }
6186
6187 void
6188 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
6189 {
6190     if (ch == 'i')
6191         *pmfl |= PMf_FOLD;
6192     else if (ch == 'g')
6193         *pmfl |= PMf_GLOBAL;
6194     else if (ch == 'c')
6195         *pmfl |= PMf_CONTINUE;
6196     else if (ch == 'o')
6197         *pmfl |= PMf_KEEP;
6198     else if (ch == 'm')
6199         *pmfl |= PMf_MULTILINE;
6200     else if (ch == 's')
6201         *pmfl |= PMf_SINGLELINE;
6202     else if (ch == 'x')
6203         *pmfl |= PMf_EXTENDED;
6204 }
6205
6206 STATIC char *
6207 S_scan_pat(pTHX_ char *start, I32 type)
6208 {
6209     PMOP *pm;
6210     char *s;
6211
6212     s = scan_str(start,FALSE,FALSE);
6213     if (!s)
6214         Perl_croak(aTHX_ "Search pattern not terminated");
6215
6216     pm = (PMOP*)newPMOP(type, 0);
6217     if (PL_multi_open == '?')
6218         pm->op_pmflags |= PMf_ONCE;
6219     if(type == OP_QR) {
6220         while (*s && strchr("iomsx", *s))
6221             pmflag(&pm->op_pmflags,*s++);
6222     }
6223     else {
6224         while (*s && strchr("iogcmsx", *s))
6225             pmflag(&pm->op_pmflags,*s++);
6226     }
6227     pm->op_pmpermflags = pm->op_pmflags;
6228
6229     PL_lex_op = (OP*)pm;
6230     yylval.ival = OP_MATCH;
6231     return s;
6232 }
6233
6234 STATIC char *
6235 S_scan_subst(pTHX_ char *start)
6236 {
6237     register char *s;
6238     register PMOP *pm;
6239     I32 first_start;
6240     I32 es = 0;
6241
6242     yylval.ival = OP_NULL;
6243
6244     s = scan_str(start,FALSE,FALSE);
6245
6246     if (!s)
6247         Perl_croak(aTHX_ "Substitution pattern not terminated");
6248
6249     if (s[-1] == PL_multi_open)
6250         s--;
6251
6252     first_start = PL_multi_start;
6253     s = scan_str(s,FALSE,FALSE);
6254     if (!s) {
6255         if (PL_lex_stuff) {
6256             SvREFCNT_dec(PL_lex_stuff);
6257             PL_lex_stuff = Nullsv;
6258         }
6259         Perl_croak(aTHX_ "Substitution replacement not terminated");
6260     }
6261     PL_multi_start = first_start;       /* so whole substitution is taken together */
6262
6263     pm = (PMOP*)newPMOP(OP_SUBST, 0);
6264     while (*s) {
6265         if (*s == 'e') {
6266             s++;
6267             es++;
6268         }
6269         else if (strchr("iogcmsx", *s))
6270             pmflag(&pm->op_pmflags,*s++);
6271         else
6272             break;
6273     }
6274
6275     if (es) {
6276         SV *repl;
6277         PL_sublex_info.super_bufptr = s;
6278         PL_sublex_info.super_bufend = PL_bufend;
6279         PL_multi_end = 0;
6280         pm->op_pmflags |= PMf_EVAL;
6281         repl = newSVpvn("",0);
6282         while (es-- > 0)
6283             sv_catpv(repl, es ? "eval " : "do ");
6284         sv_catpvn(repl, "{ ", 2);
6285         sv_catsv(repl, PL_lex_repl);
6286         sv_catpvn(repl, " };", 2);
6287         SvEVALED_on(repl);
6288         SvREFCNT_dec(PL_lex_repl);
6289         PL_lex_repl = repl;
6290     }
6291
6292     pm->op_pmpermflags = pm->op_pmflags;
6293     PL_lex_op = (OP*)pm;
6294     yylval.ival = OP_SUBST;
6295     return s;
6296 }
6297
6298 STATIC char *
6299 S_scan_trans(pTHX_ char *start)
6300 {
6301     register char* s;
6302     OP *o;
6303     short *tbl;
6304     I32 squash;
6305     I32 del;
6306     I32 complement;
6307
6308     yylval.ival = OP_NULL;
6309
6310     s = scan_str(start,FALSE,FALSE);
6311     if (!s)
6312         Perl_croak(aTHX_ "Transliteration pattern not terminated");
6313     if (s[-1] == PL_multi_open)
6314         s--;
6315
6316     s = scan_str(s,FALSE,FALSE);
6317     if (!s) {
6318         if (PL_lex_stuff) {
6319             SvREFCNT_dec(PL_lex_stuff);
6320             PL_lex_stuff = Nullsv;
6321         }
6322         Perl_croak(aTHX_ "Transliteration replacement not terminated");
6323     }
6324
6325     complement = del = squash = 0;
6326     while (strchr("cds", *s)) {
6327         if (*s == 'c')
6328             complement = OPpTRANS_COMPLEMENT;
6329         else if (*s == 'd')
6330             del = OPpTRANS_DELETE;
6331         else if (*s == 's')
6332             squash = OPpTRANS_SQUASH;
6333         s++;
6334     }
6335
6336     New(803, tbl, complement&&!del?258:256, short);
6337     o = newPVOP(OP_TRANS, 0, (char*)tbl);
6338     o->op_private = del|squash|complement|
6339       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6340       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
6341
6342     PL_lex_op = o;
6343     yylval.ival = OP_TRANS;
6344     return s;
6345 }
6346
6347 STATIC char *
6348 S_scan_heredoc(pTHX_ register char *s)
6349 {
6350     SV *herewas;
6351     I32 op_type = OP_SCALAR;
6352     I32 len;
6353     SV *tmpstr;
6354     char term;
6355     register char *d;
6356     register char *e;
6357     char *peek;
6358     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6359
6360     s += 2;
6361     d = PL_tokenbuf;
6362     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6363     if (!outer)
6364         *d++ = '\n';
6365     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6366     if (*peek && strchr("`'\"",*peek)) {
6367         s = peek;
6368         term = *s++;
6369         s = delimcpy(d, e, s, PL_bufend, term, &len);
6370         d += len;
6371         if (s < PL_bufend)
6372             s++;
6373     }
6374     else {
6375         if (*s == '\\')
6376             s++, term = '\'';
6377         else
6378             term = '"';
6379         if (!isALNUM_lazy_if(s,UTF))
6380             deprecate("bare << to mean <<\"\"");
6381         for (; isALNUM_lazy_if(s,UTF); s++) {
6382             if (d < e)
6383                 *d++ = *s;
6384         }
6385     }
6386     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6387         Perl_croak(aTHX_ "Delimiter for here document is too long");
6388     *d++ = '\n';
6389     *d = '\0';
6390     len = d - PL_tokenbuf;
6391 #ifndef PERL_STRICT_CR
6392     d = strchr(s, '\r');
6393     if (d) {
6394         char *olds = s;
6395         s = d;
6396         while (s < PL_bufend) {
6397             if (*s == '\r') {
6398                 *d++ = '\n';
6399                 if (*++s == '\n')
6400                     s++;
6401             }
6402             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
6403                 *d++ = *s++;
6404                 s++;
6405             }
6406             else
6407                 *d++ = *s++;
6408         }
6409         *d = '\0';
6410         PL_bufend = d;
6411         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6412         s = olds;
6413     }
6414 #endif
6415     d = "\n";
6416     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6417         herewas = newSVpvn(s,PL_bufend-s);
6418     else
6419         s--, herewas = newSVpvn(s,d-s);
6420     s += SvCUR(herewas);
6421
6422     tmpstr = NEWSV(87,79);
6423     sv_upgrade(tmpstr, SVt_PVIV);
6424     if (term == '\'') {
6425         op_type = OP_CONST;
6426         SvIVX(tmpstr) = -1;
6427     }
6428     else if (term == '`') {
6429         op_type = OP_BACKTICK;
6430         SvIVX(tmpstr) = '\\';
6431     }
6432
6433     CLINE;
6434     PL_multi_start = CopLINE(PL_curcop);
6435     PL_multi_open = PL_multi_close = '<';
6436     term = *PL_tokenbuf;
6437     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6438         char *bufptr = PL_sublex_info.super_bufptr;
6439         char *bufend = PL_sublex_info.super_bufend;
6440         char *olds = s - SvCUR(herewas);
6441         s = strchr(bufptr, '\n');
6442         if (!s)
6443             s = bufend;
6444         d = s;
6445         while (s < bufend &&
6446           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6447             if (*s++ == '\n')
6448                 CopLINE_inc(PL_curcop);
6449         }
6450         if (s >= bufend) {
6451             CopLINE_set(PL_curcop, PL_multi_start);
6452             missingterm(PL_tokenbuf);
6453         }
6454         sv_setpvn(herewas,bufptr,d-bufptr+1);
6455         sv_setpvn(tmpstr,d+1,s-d);
6456         s += len - 1;
6457         sv_catpvn(herewas,s,bufend-s);
6458         (void)strcpy(bufptr,SvPVX(herewas));
6459
6460         s = olds;
6461         goto retval;
6462     }
6463     else if (!outer) {
6464         d = s;
6465         while (s < PL_bufend &&
6466           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6467             if (*s++ == '\n')
6468                 CopLINE_inc(PL_curcop);
6469         }
6470         if (s >= PL_bufend) {
6471             CopLINE_set(PL_curcop, PL_multi_start);
6472             missingterm(PL_tokenbuf);
6473         }
6474         sv_setpvn(tmpstr,d+1,s-d);
6475         s += len - 1;
6476         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6477
6478         sv_catpvn(herewas,s,PL_bufend-s);
6479         sv_setsv(PL_linestr,herewas);
6480         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6481         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6482         PL_last_lop = PL_last_uni = Nullch;
6483     }
6484     else
6485         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
6486     while (s >= PL_bufend) {    /* multiple line string? */
6487         if (!outer ||
6488          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6489             CopLINE_set(PL_curcop, PL_multi_start);
6490             missingterm(PL_tokenbuf);
6491         }
6492         CopLINE_inc(PL_curcop);
6493         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6494         PL_last_lop = PL_last_uni = Nullch;
6495 #ifndef PERL_STRICT_CR
6496         if (PL_bufend - PL_linestart >= 2) {
6497             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6498                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6499             {
6500                 PL_bufend[-2] = '\n';
6501                 PL_bufend--;
6502                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6503             }
6504             else if (PL_bufend[-1] == '\r')
6505                 PL_bufend[-1] = '\n';
6506         }
6507         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6508             PL_bufend[-1] = '\n';
6509 #endif
6510         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6511             SV *sv = NEWSV(88,0);
6512
6513             sv_upgrade(sv, SVt_PVMG);
6514             sv_setsv(sv,PL_linestr);
6515             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6516         }
6517         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6518             s = PL_bufend - 1;
6519             *s = ' ';
6520             sv_catsv(PL_linestr,herewas);
6521             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6522         }
6523         else {
6524             s = PL_bufend;
6525             sv_catsv(tmpstr,PL_linestr);
6526         }
6527     }
6528     s++;
6529 retval:
6530     PL_multi_end = CopLINE(PL_curcop);
6531     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6532         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6533         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6534     }
6535     SvREFCNT_dec(herewas);
6536     if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6537         SvUTF8_on(tmpstr);
6538     PL_lex_stuff = tmpstr;
6539     yylval.ival = op_type;
6540     return s;
6541 }
6542
6543 /* scan_inputsymbol
6544    takes: current position in input buffer
6545    returns: new position in input buffer
6546    side-effects: yylval and lex_op are set.
6547
6548    This code handles:
6549
6550    <>           read from ARGV
6551    <FH>         read from filehandle
6552    <pkg::FH>    read from package qualified filehandle
6553    <pkg'FH>     read from package qualified filehandle
6554    <$fh>        read from filehandle in $fh
6555    <*.h>        filename glob
6556
6557 */
6558
6559 STATIC char *
6560 S_scan_inputsymbol(pTHX_ char *start)
6561 {
6562     register char *s = start;           /* current position in buffer */
6563     register char *d;
6564     register char *e;
6565     char *end;
6566     I32 len;
6567
6568     d = PL_tokenbuf;                    /* start of temp holding space */
6569     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
6570     end = strchr(s, '\n');
6571     if (!end)
6572         end = PL_bufend;
6573     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
6574
6575     /* die if we didn't have space for the contents of the <>,
6576        or if it didn't end, or if we see a newline
6577     */
6578
6579     if (len >= sizeof PL_tokenbuf)
6580         Perl_croak(aTHX_ "Excessively long <> operator");
6581     if (s >= end)
6582         Perl_croak(aTHX_ "Unterminated <> operator");
6583
6584     s++;
6585
6586     /* check for <$fh>
6587        Remember, only scalar variables are interpreted as filehandles by
6588        this code.  Anything more complex (e.g., <$fh{$num}>) will be
6589        treated as a glob() call.
6590        This code makes use of the fact that except for the $ at the front,
6591        a scalar variable and a filehandle look the same.
6592     */
6593     if (*d == '$' && d[1]) d++;
6594
6595     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6596     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6597         d++;
6598
6599     /* If we've tried to read what we allow filehandles to look like, and
6600        there's still text left, then it must be a glob() and not a getline.
6601        Use scan_str to pull out the stuff between the <> and treat it
6602        as nothing more than a string.
6603     */
6604
6605     if (d - PL_tokenbuf != len) {
6606         yylval.ival = OP_GLOB;
6607         set_csh();
6608         s = scan_str(start,FALSE,FALSE);
6609         if (!s)
6610            Perl_croak(aTHX_ "Glob not terminated");
6611         return s;
6612     }
6613     else {
6614         /* we're in a filehandle read situation */
6615         d = PL_tokenbuf;
6616
6617         /* turn <> into <ARGV> */
6618         if (!len)
6619             (void)strcpy(d,"ARGV");
6620
6621         /* if <$fh>, create the ops to turn the variable into a
6622            filehandle
6623         */
6624         if (*d == '$') {
6625             I32 tmp;
6626
6627             /* try to find it in the pad for this block, otherwise find
6628                add symbol table ops
6629             */
6630             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6631                 OP *o = newOP(OP_PADSV, 0);
6632                 o->op_targ = tmp;
6633                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
6634             }
6635             else {
6636                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
6637                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
6638                                             newUNOP(OP_RV2SV, 0,
6639                                                 newGVOP(OP_GV, 0, gv)));
6640             }
6641             PL_lex_op->op_flags |= OPf_SPECIAL;
6642             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6643             yylval.ival = OP_NULL;
6644         }
6645
6646         /* If it's none of the above, it must be a literal filehandle
6647            (<Foo::BAR> or <FOO>) so build a simple readline OP */
6648         else {
6649             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6650             PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6651             yylval.ival = OP_NULL;
6652         }
6653     }
6654
6655     return s;
6656 }
6657
6658
6659 /* scan_str
6660    takes: start position in buffer
6661           keep_quoted preserve \ on the embedded delimiter(s)
6662           keep_delims preserve the delimiters around the string
6663    returns: position to continue reading from buffer
6664    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6665         updates the read buffer.
6666
6667    This subroutine pulls a string out of the input.  It is called for:
6668         q               single quotes           q(literal text)
6669         '               single quotes           'literal text'
6670         qq              double quotes           qq(interpolate $here please)
6671         "               double quotes           "interpolate $here please"
6672         qx              backticks               qx(/bin/ls -l)
6673         `               backticks               `/bin/ls -l`
6674         qw              quote words             @EXPORT_OK = qw( func() $spam )
6675         m//             regexp match            m/this/
6676         s///            regexp substitute       s/this/that/
6677         tr///           string transliterate    tr/this/that/
6678         y///            string transliterate    y/this/that/
6679         ($*@)           sub prototypes          sub foo ($)
6680         (stuff)         sub attr parameters     sub foo : attr(stuff)
6681         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
6682         
6683    In most of these cases (all but <>, patterns and transliterate)
6684    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
6685    calls scan_str().  s/// makes yylex() call scan_subst() which calls
6686    scan_str().  tr/// and y/// make yylex() call scan_trans() which
6687    calls scan_str().
6688
6689    It skips whitespace before the string starts, and treats the first
6690    character as the delimiter.  If the delimiter is one of ([{< then
6691    the corresponding "close" character )]}> is used as the closing
6692    delimiter.  It allows quoting of delimiters, and if the string has
6693    balanced delimiters ([{<>}]) it allows nesting.
6694
6695    On success, the SV with the resulting string is put into lex_stuff or,
6696    if that is already non-NULL, into lex_repl. The second case occurs only
6697    when parsing the RHS of the special constructs s/// and tr/// (y///).
6698    For convenience, the terminating delimiter character is stuffed into
6699    SvIVX of the SV.
6700 */
6701
6702 STATIC char *
6703 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6704 {
6705     SV *sv;                             /* scalar value: string */
6706     char *tmps;                         /* temp string, used for delimiter matching */
6707     register char *s = start;           /* current position in the buffer */
6708     register char term;                 /* terminating character */
6709     register char *to;                  /* current position in the sv's data */
6710     I32 brackets = 1;                   /* bracket nesting level */
6711     bool has_utf8 = FALSE;              /* is there any utf8 content? */
6712
6713     /* skip space before the delimiter */
6714     if (isSPACE(*s))
6715         s = skipspace(s);
6716
6717     /* mark where we are, in case we need to report errors */
6718     CLINE;
6719
6720     /* after skipping whitespace, the next character is the terminator */
6721     term = *s;
6722     if (!UTF8_IS_INVARIANT((U8)term) && UTF)
6723         has_utf8 = TRUE;
6724
6725     /* mark where we are */
6726     PL_multi_start = CopLINE(PL_curcop);
6727     PL_multi_open = term;
6728
6729     /* find corresponding closing delimiter */
6730     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6731         term = tmps[5];
6732     PL_multi_close = term;
6733
6734     /* create a new SV to hold the contents.  87 is leak category, I'm
6735        assuming.  79 is the SV's initial length.  What a random number. */
6736     sv = NEWSV(87,79);
6737     sv_upgrade(sv, SVt_PVIV);
6738     SvIVX(sv) = term;
6739     (void)SvPOK_only(sv);               /* validate pointer */
6740
6741     /* move past delimiter and try to read a complete string */
6742     if (keep_delims)
6743         sv_catpvn(sv, s, 1);
6744     s++;
6745     for (;;) {
6746         /* extend sv if need be */
6747         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6748         /* set 'to' to the next character in the sv's string */
6749         to = SvPVX(sv)+SvCUR(sv);
6750
6751         /* if open delimiter is the close delimiter read unbridle */
6752         if (PL_multi_open == PL_multi_close) {
6753             for (; s < PL_bufend; s++,to++) {
6754                 /* embedded newlines increment the current line number */
6755                 if (*s == '\n' && !PL_rsfp)
6756                     CopLINE_inc(PL_curcop);
6757                 /* handle quoted delimiters */
6758                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6759                     if (!keep_quoted && s[1] == term)
6760                         s++;
6761                 /* any other quotes are simply copied straight through */
6762                     else
6763                         *to++ = *s++;
6764                 }
6765                 /* terminate when run out of buffer (the for() condition), or
6766                    have found the terminator */
6767                 else if (*s == term)
6768                     break;
6769                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6770                     has_utf8 = TRUE;
6771                 *to = *s;
6772             }
6773         }
6774         
6775         /* if the terminator isn't the same as the start character (e.g.,
6776            matched brackets), we have to allow more in the quoting, and
6777            be prepared for nested brackets.
6778         */
6779         else {
6780             /* read until we run out of string, or we find the terminator */
6781             for (; s < PL_bufend; s++,to++) {
6782                 /* embedded newlines increment the line count */
6783                 if (*s == '\n' && !PL_rsfp)
6784                     CopLINE_inc(PL_curcop);
6785                 /* backslashes can escape the open or closing characters */
6786                 if (*s == '\\' && s+1 < PL_bufend) {
6787                     if (!keep_quoted &&
6788                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6789                         s++;
6790                     else
6791                         *to++ = *s++;
6792                 }
6793                 /* allow nested opens and closes */
6794                 else if (*s == PL_multi_close && --brackets <= 0)
6795                     break;
6796                 else if (*s == PL_multi_open)
6797                     brackets++;
6798                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6799                     has_utf8 = TRUE;
6800                 *to = *s;
6801             }
6802         }
6803         /* terminate the copied string and update the sv's end-of-string */
6804         *to = '\0';
6805         SvCUR_set(sv, to - SvPVX(sv));
6806
6807         /*
6808          * this next chunk reads more into the buffer if we're not done yet
6809          */
6810
6811         if (s < PL_bufend)
6812             break;              /* handle case where we are done yet :-) */
6813
6814 #ifndef PERL_STRICT_CR
6815         if (to - SvPVX(sv) >= 2) {
6816             if ((to[-2] == '\r' && to[-1] == '\n') ||
6817                 (to[-2] == '\n' && to[-1] == '\r'))
6818             {
6819                 to[-2] = '\n';
6820                 to--;
6821                 SvCUR_set(sv, to - SvPVX(sv));
6822             }
6823             else if (to[-1] == '\r')
6824                 to[-1] = '\n';
6825         }
6826         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
6827             to[-1] = '\n';
6828 #endif
6829         
6830         /* if we're out of file, or a read fails, bail and reset the current
6831            line marker so we can report where the unterminated string began
6832         */
6833         if (!PL_rsfp ||
6834          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6835             sv_free(sv);
6836             CopLINE_set(PL_curcop, PL_multi_start);
6837             return Nullch;
6838         }
6839         /* we read a line, so increment our line counter */
6840         CopLINE_inc(PL_curcop);
6841
6842         /* update debugger info */
6843         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6844             SV *sv = NEWSV(88,0);
6845
6846             sv_upgrade(sv, SVt_PVMG);
6847             sv_setsv(sv,PL_linestr);
6848             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
6849         }
6850
6851         /* having changed the buffer, we must update PL_bufend */
6852         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6853         PL_last_lop = PL_last_uni = Nullch;
6854     }
6855
6856     /* at this point, we have successfully read the delimited string */
6857
6858     if (keep_delims)
6859         sv_catpvn(sv, s, 1);
6860     if (has_utf8)
6861         SvUTF8_on(sv);
6862     PL_multi_end = CopLINE(PL_curcop);
6863     s++;
6864
6865     /* if we allocated too much space, give some back */
6866     if (SvCUR(sv) + 5 < SvLEN(sv)) {
6867         SvLEN_set(sv, SvCUR(sv) + 1);
6868         Renew(SvPVX(sv), SvLEN(sv), char);
6869     }
6870
6871     /* decide whether this is the first or second quoted string we've read
6872        for this op
6873     */
6874
6875     if (PL_lex_stuff)
6876         PL_lex_repl = sv;
6877     else
6878         PL_lex_stuff = sv;
6879     return s;
6880 }
6881
6882 /*
6883   scan_num
6884   takes: pointer to position in buffer
6885   returns: pointer to new position in buffer
6886   side-effects: builds ops for the constant in yylval.op
6887
6888   Read a number in any of the formats that Perl accepts:
6889
6890   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
6891   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
6892   0b[01](_?[01])*
6893   0[0-7](_?[0-7])*
6894   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
6895
6896   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
6897   thing it reads.
6898
6899   If it reads a number without a decimal point or an exponent, it will
6900   try converting the number to an integer and see if it can do so
6901   without loss of precision.
6902 */
6903
6904 char *
6905 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
6906 {
6907     register char *s = start;           /* current position in buffer */
6908     register char *d;                   /* destination in temp buffer */
6909     register char *e;                   /* end of temp buffer */
6910     NV nv;                              /* number read, as a double */
6911     SV *sv = Nullsv;                    /* place to put the converted number */
6912     bool floatit,                       /* boolean: int or float? */
6913         octal = 0;                      /* Is this an octal number? */
6914     char *lastub = 0;                   /* position of last underbar */
6915     static char number_too_long[] = "Number too long";
6916
6917     /* We use the first character to decide what type of number this is */
6918
6919     switch (*s) {
6920     default:
6921       Perl_croak(aTHX_ "panic: scan_num");
6922
6923     /* if it starts with a 0, it could be an octal number, a decimal in
6924        0.13 disguise, or a hexadecimal number, or a binary number. */
6925     case '0':
6926         {
6927           /* variables:
6928              u          holds the "number so far"
6929              shift      the power of 2 of the base
6930                         (hex == 4, octal == 3, binary == 1)
6931              overflowed was the number more than we can hold?
6932
6933              Shift is used when we add a digit.  It also serves as an "are
6934              we in octal/hex/binary?" indicator to disallow hex characters
6935              when in octal mode.
6936            */
6937             NV n = 0.0;
6938             UV u = 0;
6939             I32 shift;
6940             bool overflowed = FALSE;
6941             static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
6942             static char* bases[5] = { "", "binary", "", "octal",
6943                                       "hexadecimal" };
6944             static char* Bases[5] = { "", "Binary", "", "Octal",
6945                                       "Hexadecimal" };
6946             static char *maxima[5] = { "",
6947                                        "0b11111111111111111111111111111111",
6948                                        "",
6949                                        "037777777777",
6950                                        "0xffffffff" };
6951             char *base, *Base, *max;
6952
6953             /* check for hex */
6954             if (s[1] == 'x') {
6955                 shift = 4;
6956                 s += 2;
6957             } else if (s[1] == 'b') {
6958                 shift = 1;
6959                 s += 2;
6960             }
6961             /* check for a decimal in disguise */
6962             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
6963                 goto decimal;
6964             /* so it must be octal */
6965             else {
6966                 shift = 3;
6967                 octal = 1;
6968                 s++;
6969             }
6970
6971             if (*s == '_') {
6972                if (ckWARN(WARN_SYNTAX))
6973                    Perl_warner(aTHX_ WARN_SYNTAX,
6974                                "Misplaced _ in number");
6975                lastub = s++;
6976             }
6977
6978             base = bases[shift];
6979             Base = Bases[shift];
6980             max  = maxima[shift];
6981
6982             /* read the rest of the number */
6983             for (;;) {
6984                 /* x is used in the overflow test,
6985                    b is the digit we're adding on. */
6986                 UV x, b;
6987
6988                 switch (*s) {
6989
6990                 /* if we don't mention it, we're done */
6991                 default:
6992                     goto out;
6993
6994                 /* _ are ignored -- but warned about if consecutive */
6995                 case '_':
6996                     if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
6997                         Perl_warner(aTHX_ WARN_SYNTAX,
6998                                     "Misplaced _ in number");
6999                     lastub = s++;
7000                     break;
7001
7002                 /* 8 and 9 are not octal */
7003                 case '8': case '9':
7004                     if (shift == 3)
7005                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7006                     /* FALL THROUGH */
7007
7008                 /* octal digits */
7009                 case '2': case '3': case '4':
7010                 case '5': case '6': case '7':
7011                     if (shift == 1)
7012                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7013                     /* FALL THROUGH */
7014
7015                 case '0': case '1':
7016                     b = *s++ & 15;              /* ASCII digit -> value of digit */
7017                     goto digit;
7018
7019                 /* hex digits */
7020                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7021                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7022                     /* make sure they said 0x */
7023                     if (shift != 4)
7024                         goto out;
7025                     b = (*s++ & 7) + 9;
7026
7027                     /* Prepare to put the digit we have onto the end
7028                        of the number so far.  We check for overflows.
7029                     */
7030
7031                   digit:
7032                     if (!overflowed) {
7033                         x = u << shift; /* make room for the digit */
7034
7035                         if ((x >> shift) != u
7036                             && !(PL_hints & HINT_NEW_BINARY)) {
7037                             overflowed = TRUE;
7038                             n = (NV) u;
7039                             if (ckWARN_d(WARN_OVERFLOW))
7040                                 Perl_warner(aTHX_ WARN_OVERFLOW,
7041                                             "Integer overflow in %s number",
7042                                             base);
7043                         } else
7044                             u = x | b;          /* add the digit to the end */
7045                     }
7046                     if (overflowed) {
7047                         n *= nvshift[shift];
7048                         /* If an NV has not enough bits in its
7049                          * mantissa to represent an UV this summing of
7050                          * small low-order numbers is a waste of time
7051                          * (because the NV cannot preserve the
7052                          * low-order bits anyway): we could just
7053                          * remember when did we overflow and in the
7054                          * end just multiply n by the right
7055                          * amount. */
7056                         n += (NV) b;
7057                     }
7058                     break;
7059                 }
7060             }
7061
7062           /* if we get here, we had success: make a scalar value from
7063              the number.
7064           */
7065           out:
7066
7067             /* final misplaced underbar check */
7068             if (s[-1] == '_') {
7069                 if (ckWARN(WARN_SYNTAX))
7070                     Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7071             }
7072
7073             sv = NEWSV(92,0);
7074             if (overflowed) {
7075                 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7076                     Perl_warner(aTHX_ WARN_PORTABLE,
7077                                 "%s number > %s non-portable",
7078                                 Base, max);
7079                 sv_setnv(sv, n);
7080             }
7081             else {
7082 #if UVSIZE > 4
7083                 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7084                     Perl_warner(aTHX_ WARN_PORTABLE,
7085                                 "%s number > %s non-portable",
7086                                 Base, max);
7087 #endif
7088                 sv_setuv(sv, u);
7089             }
7090             if (PL_hints & HINT_NEW_BINARY)
7091                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7092         }
7093         break;
7094
7095     /*
7096       handle decimal numbers.
7097       we're also sent here when we read a 0 as the first digit
7098     */
7099     case '1': case '2': case '3': case '4': case '5':
7100     case '6': case '7': case '8': case '9': case '.':
7101       decimal:
7102         d = PL_tokenbuf;
7103         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7104         floatit = FALSE;
7105
7106         /* read next group of digits and _ and copy into d */
7107         while (isDIGIT(*s) || *s == '_') {
7108             /* skip underscores, checking for misplaced ones
7109                if -w is on
7110             */
7111             if (*s == '_') {
7112                 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7113                     Perl_warner(aTHX_ WARN_SYNTAX,
7114                                 "Misplaced _ in number");
7115                 lastub = s++;
7116             }
7117             else {
7118                 /* check for end of fixed-length buffer */
7119                 if (d >= e)
7120                     Perl_croak(aTHX_ number_too_long);
7121                 /* if we're ok, copy the character */
7122                 *d++ = *s++;
7123             }
7124         }
7125
7126         /* final misplaced underbar check */
7127         if (lastub && s == lastub + 1) {
7128             if (ckWARN(WARN_SYNTAX))
7129                 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
7130         }
7131
7132         /* read a decimal portion if there is one.  avoid
7133            3..5 being interpreted as the number 3. followed
7134            by .5
7135         */
7136         if (*s == '.' && s[1] != '.') {
7137             floatit = TRUE;
7138             *d++ = *s++;
7139
7140             if (*s == '_') {
7141                 if (ckWARN(WARN_SYNTAX))
7142                     Perl_warner(aTHX_ WARN_SYNTAX,
7143                                 "Misplaced _ in number");
7144                 lastub = s;
7145             }
7146
7147             /* copy, ignoring underbars, until we run out of digits.
7148             */
7149             for (; isDIGIT(*s) || *s == '_'; s++) {
7150                 /* fixed length buffer check */
7151                 if (d >= e)
7152                     Perl_croak(aTHX_ number_too_long);
7153                 if (*s == '_') {
7154                    if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7155                        Perl_warner(aTHX_ WARN_SYNTAX,
7156                                    "Misplaced _ in number");
7157                    lastub = s;
7158                 }
7159                 else
7160                     *d++ = *s;
7161             }
7162             /* fractional part ending in underbar? */
7163             if (s[-1] == '_') {
7164                 if (ckWARN(WARN_SYNTAX))
7165                     Perl_warner(aTHX_ WARN_SYNTAX,
7166                                 "Misplaced _ in number");
7167             }
7168             if (*s == '.' && isDIGIT(s[1])) {
7169                 /* oops, it's really a v-string, but without the "v" */
7170                 s = start - 1;
7171                 goto vstring;
7172             }
7173         }
7174
7175         /* read exponent part, if present */
7176         if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7177             floatit = TRUE;
7178             s++;
7179
7180             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7181             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
7182
7183             /* stray preinitial _ */
7184             if (*s == '_') {
7185                 if (ckWARN(WARN_SYNTAX))
7186                     Perl_warner(aTHX_ WARN_SYNTAX,
7187                                 "Misplaced _ in number");
7188                 lastub = s++;
7189             }
7190
7191             /* allow positive or negative exponent */
7192             if (*s == '+' || *s == '-')
7193                 *d++ = *s++;
7194
7195             /* stray initial _ */
7196             if (*s == '_') {
7197                 if (ckWARN(WARN_SYNTAX))
7198                     Perl_warner(aTHX_ WARN_SYNTAX,
7199                                 "Misplaced _ in number");
7200                 lastub = s++;
7201             }
7202
7203             /* read digits of exponent */
7204             while (isDIGIT(*s) || *s == '_') {
7205                 if (isDIGIT(*s)) {
7206                     if (d >= e)
7207                         Perl_croak(aTHX_ number_too_long);
7208                     *d++ = *s++;
7209                 }
7210                 else {
7211                    if (ckWARN(WARN_SYNTAX) &&
7212                        ((lastub && s == lastub + 1) ||
7213                         (!isDIGIT(s[1]) && s[1] != '_')))
7214                        Perl_warner(aTHX_ WARN_SYNTAX,
7215                                    "Misplaced _ in number");
7216                    lastub = s++;
7217                 }
7218             }
7219         }
7220
7221
7222         /* make an sv from the string */
7223         sv = NEWSV(92,0);
7224
7225         /*
7226            We try to do an integer conversion first if no characters
7227            indicating "float" have been found.
7228          */
7229
7230         if (!floatit) {
7231             UV uv;
7232             int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7233
7234             if (flags == IS_NUMBER_IN_UV) {
7235               if (uv <= IV_MAX)
7236                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7237               else
7238                 sv_setuv(sv, uv);
7239             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7240               if (uv <= (UV) IV_MIN)
7241                 sv_setiv(sv, -(IV)uv);
7242               else
7243                 floatit = TRUE;
7244             } else
7245               floatit = TRUE;
7246         }
7247         if (floatit) {
7248             /* terminate the string */
7249             *d = '\0';
7250             nv = Atof(PL_tokenbuf);
7251             sv_setnv(sv, nv);
7252         }
7253
7254         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7255                        (PL_hints & HINT_NEW_INTEGER) )
7256             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7257                               (floatit ? "float" : "integer"),
7258                               sv, Nullsv, NULL);
7259         break;
7260
7261     /* if it starts with a v, it could be a v-string */
7262     case 'v':
7263 vstring:
7264         {
7265             char *pos = s;
7266             pos++;
7267             while (isDIGIT(*pos) || *pos == '_')
7268                 pos++;
7269             if (!isALPHA(*pos)) {
7270                 UV rev;
7271                 U8 tmpbuf[UTF8_MAXLEN+1];
7272                 U8 *tmpend;
7273                 s++;                            /* get past 'v' */
7274
7275                 sv = NEWSV(92,5);
7276                 sv_setpvn(sv, "", 0);
7277
7278                 for (;;) {
7279                     if (*s == '0' && isDIGIT(s[1]))
7280                         yyerror("Octal number in vector unsupported");
7281                     rev = 0;
7282                     {
7283                         /* this is atoi() that tolerates underscores */
7284                         char *end = pos;
7285                         UV mult = 1;
7286                         while (--end >= s) {
7287                             UV orev;
7288                             if (*end == '_')
7289                                 continue;
7290                             orev = rev;
7291                             rev += (*end - '0') * mult;
7292                             mult *= 10;
7293                             if (orev > rev && ckWARN_d(WARN_OVERFLOW))
7294                                 Perl_warner(aTHX_ WARN_OVERFLOW,
7295                                             "Integer overflow in decimal number");
7296                         }
7297                     }
7298                     /* Append native character for the rev point */
7299                     tmpend = uvchr_to_utf8(tmpbuf, rev);
7300                     sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
7301                     if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
7302                         SvUTF8_on(sv);
7303                     if (*pos == '.' && isDIGIT(pos[1]))
7304                         s = ++pos;
7305                     else {
7306                         s = pos;
7307                         break;
7308                     }
7309                     while (isDIGIT(*pos) || *pos == '_')
7310                         pos++;
7311                 }
7312                 SvPOK_on(sv);
7313                 SvREADONLY_on(sv);
7314             }
7315         }
7316         break;
7317     }
7318
7319     /* make the op for the constant and return */
7320
7321     if (sv) {
7322         lvalp->opval = newSVOP(OP_CONST, 0, sv);
7323         if (octal)
7324             ((SVOP *)lvalp->opval)->op_private |= OPpCONST_OCTAL;
7325     }
7326     else
7327         lvalp->opval = Nullop;
7328
7329     return s;
7330 }
7331
7332 STATIC char *
7333 S_scan_formline(pTHX_ register char *s)
7334 {
7335     register char *eol;
7336     register char *t;
7337     SV *stuff = newSVpvn("",0);
7338     bool needargs = FALSE;
7339
7340     while (!needargs) {
7341         if (*s == '.' || *s == /*{*/'}') {
7342             /*SUPPRESS 530*/
7343 #ifdef PERL_STRICT_CR
7344             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7345 #else
7346             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7347 #endif
7348             if (*t == '\n' || t == PL_bufend)
7349                 break;
7350         }
7351         if (PL_in_eval && !PL_rsfp) {
7352             eol = strchr(s,'\n');
7353             if (!eol++)
7354                 eol = PL_bufend;
7355         }
7356         else
7357             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7358         if (*s != '#') {
7359             for (t = s; t < eol; t++) {
7360                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7361                     needargs = FALSE;
7362                     goto enough;        /* ~~ must be first line in formline */
7363                 }
7364                 if (*t == '@' || *t == '^')
7365                     needargs = TRUE;
7366             }
7367             sv_catpvn(stuff, s, eol-s);
7368 #ifndef PERL_STRICT_CR
7369             if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7370                 char *end = SvPVX(stuff) + SvCUR(stuff);
7371                 end[-2] = '\n';
7372                 end[-1] = '\0';
7373                 SvCUR(stuff)--;
7374             }
7375 #endif
7376         }
7377         s = eol;
7378         if (PL_rsfp) {
7379             s = filter_gets(PL_linestr, PL_rsfp, 0);
7380             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7381             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7382             PL_last_lop = PL_last_uni = Nullch;
7383             if (!s) {
7384                 s = PL_bufptr;
7385                 yyerror("Format not terminated");
7386                 break;
7387             }
7388         }
7389         incline(s);
7390     }
7391   enough:
7392     if (SvCUR(stuff)) {
7393         PL_expect = XTERM;
7394         if (needargs) {
7395             PL_lex_state = LEX_NORMAL;
7396             PL_nextval[PL_nexttoke].ival = 0;
7397             force_next(',');
7398         }
7399         else
7400             PL_lex_state = LEX_FORMLINE;
7401         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7402         force_next(THING);
7403         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7404         force_next(LSTOP);
7405     }
7406     else {
7407         SvREFCNT_dec(stuff);
7408         PL_lex_formbrack = 0;
7409         PL_bufptr = s;
7410     }
7411     return s;
7412 }
7413
7414 STATIC void
7415 S_set_csh(pTHX)
7416 {
7417 #ifdef CSH
7418     if (!PL_cshlen)
7419         PL_cshlen = strlen(PL_cshname);
7420 #endif
7421 }
7422
7423 I32
7424 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7425 {
7426     I32 oldsavestack_ix = PL_savestack_ix;
7427     CV* outsidecv = PL_compcv;
7428     AV* comppadlist;
7429
7430     if (PL_compcv) {
7431         assert(SvTYPE(PL_compcv) == SVt_PVCV);
7432     }
7433     SAVEI32(PL_subline);
7434     save_item(PL_subname);
7435     SAVEI32(PL_padix);
7436     SAVECOMPPAD();
7437     SAVESPTR(PL_comppad_name);
7438     SAVESPTR(PL_compcv);
7439     SAVEI32(PL_comppad_name_fill);
7440     SAVEI32(PL_min_intro_pending);
7441     SAVEI32(PL_max_intro_pending);
7442     SAVEI32(PL_pad_reset_pending);
7443
7444     PL_compcv = (CV*)NEWSV(1104,0);
7445     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7446     CvFLAGS(PL_compcv) |= flags;
7447
7448     PL_comppad = newAV();
7449     av_push(PL_comppad, Nullsv);
7450     PL_curpad = AvARRAY(PL_comppad);
7451     PL_comppad_name = newAV();
7452     PL_comppad_name_fill = 0;
7453     PL_min_intro_pending = 0;
7454     PL_padix = 0;
7455     PL_subline = CopLINE(PL_curcop);
7456 #ifdef USE_THREADS
7457     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7458     PL_curpad[0] = (SV*)newAV();
7459     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
7460 #endif /* USE_THREADS */
7461
7462     comppadlist = newAV();
7463     AvREAL_off(comppadlist);
7464     av_store(comppadlist, 0, (SV*)PL_comppad_name);
7465     av_store(comppadlist, 1, (SV*)PL_comppad);
7466
7467     CvPADLIST(PL_compcv) = comppadlist;
7468     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7469 #ifdef USE_THREADS
7470     CvOWNER(PL_compcv) = 0;
7471     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7472     MUTEX_INIT(CvMUTEXP(PL_compcv));
7473 #endif /* USE_THREADS */
7474
7475     return oldsavestack_ix;
7476 }
7477
7478 #ifdef __SC__
7479 #pragma segment Perl_yylex
7480 #endif
7481 int
7482 Perl_yywarn(pTHX_ char *s)
7483 {
7484     PL_in_eval |= EVAL_WARNONLY;
7485     yyerror(s);
7486     PL_in_eval &= ~EVAL_WARNONLY;
7487     return 0;
7488 }
7489
7490 int
7491 Perl_yyerror(pTHX_ char *s)
7492 {
7493     char *where = NULL;
7494     char *context = NULL;
7495     int contlen = -1;
7496     SV *msg;
7497
7498     if (!yychar || (yychar == ';' && !PL_rsfp))
7499         where = "at EOF";
7500     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7501       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7502         while (isSPACE(*PL_oldoldbufptr))
7503             PL_oldoldbufptr++;
7504         context = PL_oldoldbufptr;
7505         contlen = PL_bufptr - PL_oldoldbufptr;
7506     }
7507     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7508       PL_oldbufptr != PL_bufptr) {
7509         while (isSPACE(*PL_oldbufptr))
7510             PL_oldbufptr++;
7511         context = PL_oldbufptr;
7512         contlen = PL_bufptr - PL_oldbufptr;
7513     }
7514     else if (yychar > 255)
7515         where = "next token ???";
7516 #ifdef USE_PURE_BISON
7517 /*  GNU Bison sets the value -2 */
7518     else if (yychar == -2) {
7519 #else
7520     else if ((yychar & 127) == 127) {
7521 #endif
7522         if (PL_lex_state == LEX_NORMAL ||
7523            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7524             where = "at end of line";
7525         else if (PL_lex_inpat)
7526             where = "within pattern";
7527         else
7528             where = "within string";
7529     }
7530     else {
7531         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7532         if (yychar < 32)
7533             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7534         else if (isPRINT_LC(yychar))
7535             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7536         else
7537             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7538         where = SvPVX(where_sv);
7539     }
7540     msg = sv_2mortal(newSVpv(s, 0));
7541     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7542                    CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7543     if (context)
7544         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7545     else
7546         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7547     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7548         Perl_sv_catpvf(aTHX_ msg,
7549         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7550                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7551         PL_multi_end = 0;
7552     }
7553     if (PL_in_eval & EVAL_WARNONLY)
7554         Perl_warn(aTHX_ "%"SVf, msg);
7555     else
7556         qerror(msg);
7557     if (PL_error_count >= 10) {
7558         if (PL_in_eval && SvCUR(ERRSV))
7559             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7560                        ERRSV, CopFILE(PL_curcop));
7561         else
7562             Perl_croak(aTHX_ "%s has too many errors.\n",
7563                        CopFILE(PL_curcop));
7564     }
7565     PL_in_my = 0;
7566     PL_in_my_stash = Nullhv;
7567     return 0;
7568 }
7569 #ifdef __SC__
7570 #pragma segment Main
7571 #endif
7572
7573 STATIC char*
7574 S_swallow_bom(pTHX_ U8 *s)
7575 {
7576     STRLEN slen;
7577     slen = SvCUR(PL_linestr);
7578     switch (*s) {
7579     case 0xFF:
7580         if (s[1] == 0xFE) {
7581             /* UTF-16 little-endian */
7582             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
7583                 Perl_croak(aTHX_ "Unsupported script encoding");
7584 #ifndef PERL_NO_UTF16_FILTER
7585             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7586             s += 2;
7587             if (PL_bufend > (char*)s) {
7588                 U8 *news;
7589                 I32 newlen;
7590
7591                 filter_add(utf16rev_textfilter, NULL);
7592                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7593                 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7594                                                  PL_bufend - (char*)s - 1,
7595                                                  &newlen);
7596                 Copy(news, s, newlen, U8);
7597                 SvCUR_set(PL_linestr, newlen);
7598                 PL_bufend = SvPVX(PL_linestr) + newlen;
7599                 news[newlen++] = '\0';
7600                 Safefree(news);
7601             }
7602 #else
7603             Perl_croak(aTHX_ "Unsupported script encoding");
7604 #endif
7605         }
7606         break;
7607     case 0xFE:
7608         if (s[1] == 0xFF) {   /* UTF-16 big-endian */
7609 #ifndef PERL_NO_UTF16_FILTER
7610             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7611             s += 2;
7612             if (PL_bufend > (char *)s) {
7613                 U8 *news;
7614                 I32 newlen;
7615
7616                 filter_add(utf16_textfilter, NULL);
7617                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7618                 PL_bufend = (char*)utf16_to_utf8(s, news,
7619                                                  PL_bufend - (char*)s,
7620                                                  &newlen);
7621                 Copy(news, s, newlen, U8);
7622                 SvCUR_set(PL_linestr, newlen);
7623                 PL_bufend = SvPVX(PL_linestr) + newlen;
7624                 news[newlen++] = '\0';
7625                 Safefree(news);
7626             }
7627 #else
7628             Perl_croak(aTHX_ "Unsupported script encoding");
7629 #endif
7630         }
7631         break;
7632     case 0xEF:
7633         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7634             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7635             s += 3;                      /* UTF-8 */
7636         }
7637         break;
7638     case 0:
7639         if (slen > 3 && s[1] == 0 &&  /* UTF-32 big-endian */
7640             s[2] == 0xFE && s[3] == 0xFF)
7641         {
7642             Perl_croak(aTHX_ "Unsupported script encoding");
7643         }
7644     }
7645     return (char*)s;
7646 }
7647
7648 #ifdef PERL_OBJECT
7649 #include "XSUB.h"
7650 #endif
7651
7652 /*
7653  * restore_rsfp
7654  * Restore a source filter.
7655  */
7656
7657 static void
7658 restore_rsfp(pTHXo_ void *f)
7659 {
7660     PerlIO *fp = (PerlIO*)f;
7661
7662     if (PL_rsfp == PerlIO_stdin())
7663         PerlIO_clearerr(PL_rsfp);
7664     else if (PL_rsfp && (PL_rsfp != fp))
7665         PerlIO_close(PL_rsfp);
7666     PL_rsfp = fp;
7667 }
7668
7669 #ifndef PERL_NO_UTF16_FILTER
7670 static I32
7671 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
7672 {
7673     I32 count = FILTER_READ(idx+1, sv, maxlen);
7674     if (count) {
7675         U8* tmps;
7676         U8* tend;
7677         I32 newlen;
7678         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7679         if (!*SvPV_nolen(sv))
7680         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7681         return count;
7682
7683         tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7684         sv_usepvn(sv, (char*)tmps, tend - tmps);
7685     }
7686     return count;
7687 }
7688
7689 static I32
7690 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
7691 {
7692     I32 count = FILTER_READ(idx+1, sv, maxlen);
7693     if (count) {
7694         U8* tmps;
7695         U8* tend;
7696         I32 newlen;
7697         if (!*SvPV_nolen(sv))
7698         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7699         return count;
7700
7701         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7702         tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7703         sv_usepvn(sv, (char*)tmps, tend - tmps);
7704     }
7705     return count;
7706 }
7707 #endif