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