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