document how to set APPLLIB_EXP
[perl.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     SAVEPPTR(PL_lex_brackstack);
428     SAVEPPTR(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     SAVEFREEPV(PL_lex_brackstack);
444     SAVEFREEPV(PL_lex_casestack);
445     PL_lex_casemods = 0;
446     *PL_lex_casestack = '\0';
447     PL_lex_dojoin = 0;
448     PL_lex_starts = 0;
449     PL_lex_stuff = Nullsv;
450     PL_lex_repl = Nullsv;
451     PL_lex_inpat = 0;
452     PL_nexttoke = 0;
453     PL_lex_inwhat = 0;
454     PL_sublex_info.sub_inwhat = 0;
455     PL_linestr = line;
456     if (SvREADONLY(PL_linestr))
457         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
458     s = SvPV(PL_linestr, len);
459     if (!len || s[len-1] != ';') {
460         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
461             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
462         sv_catpvn(PL_linestr, "\n;", 2);
463     }
464     SvTEMP_off(PL_linestr);
465     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
466     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
467     PL_last_lop = PL_last_uni = Nullch;
468     PL_rsfp = 0;
469 }
470
471 /*
472  * Perl_lex_end
473  * Finalizer for lexing operations.  Must be called when the parser is
474  * done with the lexer.
475  */
476
477 void
478 Perl_lex_end(pTHX)
479 {
480     PL_doextract = FALSE;
481 }
482
483 /*
484  * S_incline
485  * This subroutine has nothing to do with tilting, whether at windmills
486  * or pinball tables.  Its name is short for "increment line".  It
487  * increments the current line number in CopLINE(PL_curcop) and checks
488  * to see whether the line starts with a comment of the form
489  *    # line 500 "foo.pm"
490  * If so, it sets the current line number and file to the values in the comment.
491  */
492
493 STATIC void
494 S_incline(pTHX_ char *s)
495 {
496     char *t;
497     char *n;
498     char *e;
499     char ch;
500
501     CopLINE_inc(PL_curcop);
502     if (*s++ != '#')
503         return;
504     while (SPACE_OR_TAB(*s)) s++;
505     if (strnEQ(s, "line", 4))
506         s += 4;
507     else
508         return;
509     if (SPACE_OR_TAB(*s))
510         s++;
511     else
512         return;
513     while (SPACE_OR_TAB(*s)) s++;
514     if (!isDIGIT(*s))
515         return;
516     n = s;
517     while (isDIGIT(*s))
518         s++;
519     while (SPACE_OR_TAB(*s))
520         s++;
521     if (*s == '"' && (t = strchr(s+1, '"'))) {
522         s++;
523         e = t + 1;
524     }
525     else {
526         for (t = s; !isSPACE(*t); t++) ;
527         e = t;
528     }
529     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
530         e++;
531     if (*e != '\n' && *e != '\0')
532         return;         /* false alarm */
533
534     ch = *t;
535     *t = '\0';
536     if (t - s > 0) {
537         CopFILE_free(PL_curcop);
538         CopFILE_set(PL_curcop, s);
539     }
540     *t = ch;
541     CopLINE_set(PL_curcop, atoi(n)-1);
542 }
543
544 /*
545  * S_skipspace
546  * Called to gobble the appropriate amount and type of whitespace.
547  * Skips comments as well.
548  */
549
550 STATIC char *
551 S_skipspace(pTHX_ register char *s)
552 {
553     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
554         while (s < PL_bufend && SPACE_OR_TAB(*s))
555             s++;
556         return s;
557     }
558     for (;;) {
559         STRLEN prevlen;
560         SSize_t oldprevlen, oldoldprevlen;
561         SSize_t oldloplen = 0, oldunilen = 0;
562         while (s < PL_bufend && isSPACE(*s)) {
563             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
564                 incline(s);
565         }
566
567         /* comment */
568         if (s < PL_bufend && *s == '#') {
569             while (s < PL_bufend && *s != '\n')
570                 s++;
571             if (s < PL_bufend) {
572                 s++;
573                 if (PL_in_eval && !PL_rsfp) {
574                     incline(s);
575                     continue;
576                 }
577             }
578         }
579
580         /* only continue to recharge the buffer if we're at the end
581          * of the buffer, we're not reading from a source filter, and
582          * we're in normal lexing mode
583          */
584         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
585                 PL_lex_state == LEX_FORMLINE)
586             return s;
587
588         /* try to recharge the buffer */
589         if ((s = filter_gets(PL_linestr, PL_rsfp,
590                              (prevlen = SvCUR(PL_linestr)))) == Nullch)
591         {
592             /* end of file.  Add on the -p or -n magic */
593             if (PL_minus_n || PL_minus_p) {
594                 sv_setpv(PL_linestr,PL_minus_p ?
595                          ";}continue{print or die qq(-p destination: $!\\n)" :
596                          "");
597                 sv_catpv(PL_linestr,";}");
598                 PL_minus_n = PL_minus_p = 0;
599             }
600             else
601                 sv_setpv(PL_linestr,";");
602
603             /* reset variables for next time we lex */
604             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
605                 = SvPVX(PL_linestr);
606             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
607             PL_last_lop = PL_last_uni = Nullch;
608
609             /* Close the filehandle.  Could be from -P preprocessor,
610              * STDIN, or a regular file.  If we were reading code from
611              * STDIN (because the commandline held no -e or filename)
612              * then we don't close it, we reset it so the code can
613              * read from STDIN too.
614              */
615
616             if (PL_preprocess && !PL_in_eval)
617                 (void)PerlProc_pclose(PL_rsfp);
618             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
619                 PerlIO_clearerr(PL_rsfp);
620             else
621                 (void)PerlIO_close(PL_rsfp);
622             PL_rsfp = Nullfp;
623             return s;
624         }
625
626         /* not at end of file, so we only read another line */
627         /* make corresponding updates to old pointers, for yyerror() */
628         oldprevlen = PL_oldbufptr - PL_bufend;
629         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
630         if (PL_last_uni)
631             oldunilen = PL_last_uni - PL_bufend;
632         if (PL_last_lop)
633             oldloplen = PL_last_lop - PL_bufend;
634         PL_linestart = PL_bufptr = s + prevlen;
635         PL_bufend = s + SvCUR(PL_linestr);
636         s = PL_bufptr;
637         PL_oldbufptr = s + oldprevlen;
638         PL_oldoldbufptr = s + oldoldprevlen;
639         if (PL_last_uni)
640             PL_last_uni = s + oldunilen;
641         if (PL_last_lop)
642             PL_last_lop = s + oldloplen;
643         incline(s);
644
645         /* debugger active and we're not compiling the debugger code,
646          * so store the line into the debugger's array of lines
647          */
648         if (PERLDB_LINE && PL_curstash != PL_debstash) {
649             SV *sv = NEWSV(85,0);
650
651             sv_upgrade(sv, SVt_PVMG);
652             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
653             (void)SvIOK_on(sv);
654             SvIVX(sv) = 0;
655             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
656         }
657     }
658 }
659
660 /*
661  * S_check_uni
662  * Check the unary operators to ensure there's no ambiguity in how they're
663  * used.  An ambiguous piece of code would be:
664  *     rand + 5
665  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
666  * the +5 is its argument.
667  */
668
669 STATIC void
670 S_check_uni(pTHX)
671 {
672     char *s;
673     char *t;
674
675     if (PL_oldoldbufptr != PL_last_uni)
676         return;
677     while (isSPACE(*PL_last_uni))
678         PL_last_uni++;
679     for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
680     if ((t = strchr(s, '(')) && t < PL_bufptr)
681         return;
682     if (ckWARN_d(WARN_AMBIGUOUS)){
683         char ch = *s;
684         *s = '\0';
685         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
686                    "Warning: Use of \"%s\" without parens is ambiguous",
687                    PL_last_uni);
688         *s = ch;
689     }
690 }
691
692 /*
693  * LOP : macro to build a list operator.  Its behaviour has been replaced
694  * with a subroutine, S_lop() for which LOP is just another name.
695  */
696
697 #define LOP(f,x) return lop(f,x,s)
698
699 /*
700  * S_lop
701  * Build a list operator (or something that might be one).  The rules:
702  *  - if we have a next token, then it's a list operator [why?]
703  *  - if the next thing is an opening paren, then it's a function
704  *  - else it's a list operator
705  */
706
707 STATIC I32
708 S_lop(pTHX_ I32 f, int x, char *s)
709 {
710     yylval.ival = f;
711     CLINE;
712     REPORT("lop", f)
713     PL_expect = x;
714     PL_bufptr = s;
715     PL_last_lop = PL_oldbufptr;
716     PL_last_lop_op = (OPCODE)f;
717     if (PL_nexttoke)
718         return LSTOP;
719     if (*s == '(')
720         return FUNC;
721     s = skipspace(s);
722     if (*s == '(')
723         return FUNC;
724     else
725         return LSTOP;
726 }
727
728 /*
729  * S_force_next
730  * When the lexer realizes it knows the next token (for instance,
731  * it is reordering tokens for the parser) then it can call S_force_next
732  * to know what token to return the next time the lexer is called.  Caller
733  * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
734  * handles the token correctly.
735  */
736
737 STATIC void
738 S_force_next(pTHX_ I32 type)
739 {
740     PL_nexttype[PL_nexttoke] = type;
741     PL_nexttoke++;
742     if (PL_lex_state != LEX_KNOWNEXT) {
743         PL_lex_defer = PL_lex_state;
744         PL_lex_expect = PL_expect;
745         PL_lex_state = LEX_KNOWNEXT;
746     }
747 }
748
749 /*
750  * S_force_word
751  * When the lexer knows the next thing is a word (for instance, it has
752  * just seen -> and it knows that the next char is a word char, then
753  * it calls S_force_word to stick the next word into the PL_next lookahead.
754  *
755  * Arguments:
756  *   char *start : buffer position (must be within PL_linestr)
757  *   int token   : PL_next will be this type of bare word (e.g., METHOD,WORD)
758  *   int check_keyword : if true, Perl checks to make sure the word isn't
759  *       a keyword (do this if the word is a label, e.g. goto FOO)
760  *   int allow_pack : if true, : characters will also be allowed (require,
761  *       use, etc. do this)
762  *   int allow_initial_tick : used by the "sub" lexer only.
763  */
764
765 STATIC char *
766 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
767 {
768     register char *s;
769     STRLEN len;
770
771     start = skipspace(start);
772     s = start;
773     if (isIDFIRST_lazy_if(s,UTF) ||
774         (allow_pack && *s == ':') ||
775         (allow_initial_tick && *s == '\'') )
776     {
777         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
778         if (check_keyword && keyword(PL_tokenbuf, len))
779             return start;
780         if (token == METHOD) {
781             s = skipspace(s);
782             if (*s == '(')
783                 PL_expect = XTERM;
784             else {
785                 PL_expect = XOPERATOR;
786             }
787         }
788         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
789         PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
790         force_next(token);
791     }
792     return s;
793 }
794
795 /*
796  * S_force_ident
797  * Called when the lexer wants $foo *foo &foo etc, but the program
798  * text only contains the "foo" portion.  The first argument is a pointer
799  * to the "foo", and the second argument is the type symbol to prefix.
800  * Forces the next token to be a "WORD".
801  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
802  */
803
804 STATIC void
805 S_force_ident(pTHX_ register char *s, int kind)
806 {
807     if (s && *s) {
808         OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
809         PL_nextval[PL_nexttoke].opval = o;
810         force_next(WORD);
811         if (kind) {
812             o->op_private = OPpCONST_ENTERED;
813             /* XXX see note in pp_entereval() for why we forgo typo
814                warnings if the symbol must be introduced in an eval.
815                GSAR 96-10-12 */
816             gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
817                 kind == '$' ? SVt_PV :
818                 kind == '@' ? SVt_PVAV :
819                 kind == '%' ? SVt_PVHV :
820                               SVt_PVGV
821                 );
822         }
823     }
824 }
825
826 NV
827 Perl_str_to_version(pTHX_ SV *sv)
828 {
829     NV retval = 0.0;
830     NV nshift = 1.0;
831     STRLEN len;
832     char *start = SvPVx(sv,len);
833     bool utf = SvUTF8(sv) ? TRUE : FALSE;
834     char *end = start + len;
835     while (start < end) {
836         STRLEN skip;
837         UV n;
838         if (utf)
839             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
840         else {
841             n = *(U8*)start;
842             skip = 1;
843         }
844         retval += ((NV)n)/nshift;
845         start += skip;
846         nshift *= 1000;
847     }
848     return retval;
849 }
850
851 /*
852  * S_force_version
853  * Forces the next token to be a version number.
854  * If the next token appears to be an invalid version number, (e.g. "v2b"),
855  * and if "guessing" is TRUE, then no new token is created (and the caller
856  * must use an alternative parsing method).
857  */
858
859 STATIC char *
860 S_force_version(pTHX_ char *s, int guessing)
861 {
862     OP *version = Nullop;
863     char *d;
864
865     s = skipspace(s);
866
867     d = s;
868     if (*d == 'v')
869         d++;
870     if (isDIGIT(*d)) {
871         while (isDIGIT(*d) || *d == '_' || *d == '.')
872             d++;
873         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
874             SV *ver;
875             s = scan_num(s, &yylval);
876             version = yylval.opval;
877             ver = cSVOPx(version)->op_sv;
878             if (SvPOK(ver) && !SvNIOK(ver)) {
879                 (void)SvUPGRADE(ver, SVt_PVNV);
880                 SvNVX(ver) = str_to_version(ver);
881                 SvNOK_on(ver);          /* hint that it is a version */
882             }
883         }
884         else if (guessing)
885             return s;
886     }
887
888     /* NOTE: The parser sees the package name and the VERSION swapped */
889     PL_nextval[PL_nexttoke].opval = version;
890     force_next(WORD);
891
892     return s;
893 }
894
895 /*
896  * S_tokeq
897  * Tokenize a quoted string passed in as an SV.  It finds the next
898  * chunk, up to end of string or a backslash.  It may make a new
899  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
900  * turns \\ into \.
901  */
902
903 STATIC SV *
904 S_tokeq(pTHX_ SV *sv)
905 {
906     register char *s;
907     register char *send;
908     register char *d;
909     STRLEN len = 0;
910     SV *pv = sv;
911
912     if (!SvLEN(sv))
913         goto finish;
914
915     s = SvPV_force(sv, len);
916     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
917         goto finish;
918     send = s + len;
919     while (s < send && *s != '\\')
920         s++;
921     if (s == send)
922         goto finish;
923     d = s;
924     if ( PL_hints & HINT_NEW_STRING ) {
925         pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
926         if (SvUTF8(sv))
927             SvUTF8_on(pv);
928     }
929     while (s < send) {
930         if (*s == '\\') {
931             if (s + 1 < send && (s[1] == '\\'))
932                 s++;            /* all that, just for this */
933         }
934         *d++ = *s++;
935     }
936     *d = '\0';
937     SvCUR_set(sv, d - SvPVX(sv));
938   finish:
939     if ( PL_hints & HINT_NEW_STRING )
940        return new_constant(NULL, 0, "q", sv, pv, "q");
941     return sv;
942 }
943
944 /*
945  * Now come three functions related to double-quote context,
946  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
947  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
948  * interact with PL_lex_state, and create fake ( ... ) argument lists
949  * to handle functions and concatenation.
950  * They assume that whoever calls them will be setting up a fake
951  * join call, because each subthing puts a ',' after it.  This lets
952  *   "lower \luPpEr"
953  * become
954  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
955  *
956  * (I'm not sure whether the spurious commas at the end of lcfirst's
957  * arguments and join's arguments are created or not).
958  */
959
960 /*
961  * S_sublex_start
962  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
963  *
964  * Pattern matching will set PL_lex_op to the pattern-matching op to
965  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
966  *
967  * OP_CONST and OP_READLINE are easy--just make the new op and return.
968  *
969  * Everything else becomes a FUNC.
970  *
971  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
972  * had an OP_CONST or OP_READLINE).  This just sets us up for a
973  * call to S_sublex_push().
974  */
975
976 STATIC I32
977 S_sublex_start(pTHX)
978 {
979     register I32 op_type = yylval.ival;
980
981     if (op_type == OP_NULL) {
982         yylval.opval = PL_lex_op;
983         PL_lex_op = Nullop;
984         return THING;
985     }
986     if (op_type == OP_CONST || op_type == OP_READLINE) {
987         SV *sv = tokeq(PL_lex_stuff);
988
989         if (SvTYPE(sv) == SVt_PVIV) {
990             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
991             STRLEN len;
992             char *p;
993             SV *nsv;
994
995             p = SvPV(sv, len);
996             nsv = newSVpvn(p, len);
997             if (SvUTF8(sv))
998                 SvUTF8_on(nsv);
999             SvREFCNT_dec(sv);
1000             sv = nsv;
1001         }
1002         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1003         PL_lex_stuff = Nullsv;
1004         /* Allow <FH> // "foo" */
1005         if (op_type == OP_READLINE)
1006             PL_expect = XTERMORDORDOR;
1007         return THING;
1008     }
1009
1010     PL_sublex_info.super_state = PL_lex_state;
1011     PL_sublex_info.sub_inwhat = op_type;
1012     PL_sublex_info.sub_op = PL_lex_op;
1013     PL_lex_state = LEX_INTERPPUSH;
1014
1015     PL_expect = XTERM;
1016     if (PL_lex_op) {
1017         yylval.opval = PL_lex_op;
1018         PL_lex_op = Nullop;
1019         return PMFUNC;
1020     }
1021     else
1022         return FUNC;
1023 }
1024
1025 /*
1026  * S_sublex_push
1027  * Create a new scope to save the lexing state.  The scope will be
1028  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1029  * to the uc, lc, etc. found before.
1030  * Sets PL_lex_state to LEX_INTERPCONCAT.
1031  */
1032
1033 STATIC I32
1034 S_sublex_push(pTHX)
1035 {
1036     ENTER;
1037
1038     PL_lex_state = PL_sublex_info.super_state;
1039     SAVEI32(PL_lex_dojoin);
1040     SAVEI32(PL_lex_brackets);
1041     SAVEI32(PL_lex_casemods);
1042     SAVEI32(PL_lex_starts);
1043     SAVEI32(PL_lex_state);
1044     SAVEVPTR(PL_lex_inpat);
1045     SAVEI32(PL_lex_inwhat);
1046     SAVECOPLINE(PL_curcop);
1047     SAVEPPTR(PL_bufptr);
1048     SAVEPPTR(PL_bufend);
1049     SAVEPPTR(PL_oldbufptr);
1050     SAVEPPTR(PL_oldoldbufptr);
1051     SAVEPPTR(PL_last_lop);
1052     SAVEPPTR(PL_last_uni);
1053     SAVEPPTR(PL_linestart);
1054     SAVESPTR(PL_linestr);
1055     SAVEPPTR(PL_lex_brackstack);
1056     SAVEPPTR(PL_lex_casestack);
1057
1058     PL_linestr = PL_lex_stuff;
1059     PL_lex_stuff = Nullsv;
1060
1061     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1062         = SvPVX(PL_linestr);
1063     PL_bufend += SvCUR(PL_linestr);
1064     PL_last_lop = PL_last_uni = Nullch;
1065     SAVEFREESV(PL_linestr);
1066
1067     PL_lex_dojoin = FALSE;
1068     PL_lex_brackets = 0;
1069     New(899, PL_lex_brackstack, 120, char);
1070     New(899, PL_lex_casestack, 12, char);
1071     SAVEFREEPV(PL_lex_brackstack);
1072     SAVEFREEPV(PL_lex_casestack);
1073     PL_lex_casemods = 0;
1074     *PL_lex_casestack = '\0';
1075     PL_lex_starts = 0;
1076     PL_lex_state = LEX_INTERPCONCAT;
1077     CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1078
1079     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1080     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1081         PL_lex_inpat = PL_sublex_info.sub_op;
1082     else
1083         PL_lex_inpat = Nullop;
1084
1085     return '(';
1086 }
1087
1088 /*
1089  * S_sublex_done
1090  * Restores lexer state after a S_sublex_push.
1091  */
1092
1093 STATIC I32
1094 S_sublex_done(pTHX)
1095 {
1096     if (!PL_lex_starts++) {
1097         SV *sv = newSVpvn("",0);
1098         if (SvUTF8(PL_linestr))
1099             SvUTF8_on(sv);
1100         PL_expect = XOPERATOR;
1101         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1102         return THING;
1103     }
1104
1105     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1106         PL_lex_state = LEX_INTERPCASEMOD;
1107         return yylex();
1108     }
1109
1110     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1111     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1112         PL_linestr = PL_lex_repl;
1113         PL_lex_inpat = 0;
1114         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1115         PL_bufend += SvCUR(PL_linestr);
1116         PL_last_lop = PL_last_uni = Nullch;
1117         SAVEFREESV(PL_linestr);
1118         PL_lex_dojoin = FALSE;
1119         PL_lex_brackets = 0;
1120         PL_lex_casemods = 0;
1121         *PL_lex_casestack = '\0';
1122         PL_lex_starts = 0;
1123         if (SvEVALED(PL_lex_repl)) {
1124             PL_lex_state = LEX_INTERPNORMAL;
1125             PL_lex_starts++;
1126             /*  we don't clear PL_lex_repl here, so that we can check later
1127                 whether this is an evalled subst; that means we rely on the
1128                 logic to ensure sublex_done() is called again only via the
1129                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1130         }
1131         else {
1132             PL_lex_state = LEX_INTERPCONCAT;
1133             PL_lex_repl = Nullsv;
1134         }
1135         return ',';
1136     }
1137     else {
1138         LEAVE;
1139         PL_bufend = SvPVX(PL_linestr);
1140         PL_bufend += SvCUR(PL_linestr);
1141         PL_expect = XOPERATOR;
1142         PL_sublex_info.sub_inwhat = 0;
1143         return ')';
1144     }
1145 }
1146
1147 /*
1148   scan_const
1149
1150   Extracts a pattern, double-quoted string, or transliteration.  This
1151   is terrifying code.
1152
1153   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1154   processing a pattern (PL_lex_inpat is true), a transliteration
1155   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1156
1157   Returns a pointer to the character scanned up to. Iff this is
1158   advanced from the start pointer supplied (ie if anything was
1159   successfully parsed), will leave an OP for the substring scanned
1160   in yylval. Caller must intuit reason for not parsing further
1161   by looking at the next characters herself.
1162
1163   In patterns:
1164     backslashes:
1165       double-quoted style: \r and \n
1166       regexp special ones: \D \s
1167       constants: \x3
1168       backrefs: \1 (deprecated in substitution replacements)
1169       case and quoting: \U \Q \E
1170     stops on @ and $, but not for $ as tail anchor
1171
1172   In transliterations:
1173     characters are VERY literal, except for - not at the start or end
1174     of the string, which indicates a range.  scan_const expands the
1175     range to the full set of intermediate characters.
1176
1177   In double-quoted strings:
1178     backslashes:
1179       double-quoted style: \r and \n
1180       constants: \x3
1181       backrefs: \1 (deprecated)
1182       case and quoting: \U \Q \E
1183     stops on @ and $
1184
1185   scan_const does *not* construct ops to handle interpolated strings.
1186   It stops processing as soon as it finds an embedded $ or @ variable
1187   and leaves it to the caller to work out what's going on.
1188
1189   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1190
1191   $ in pattern could be $foo or could be tail anchor.  Assumption:
1192   it's a tail anchor if $ is the last thing in the string, or if it's
1193   followed by one of ")| \n\t"
1194
1195   \1 (backreferences) are turned into $1
1196
1197   The structure of the code is
1198       while (there's a character to process) {
1199           handle transliteration ranges
1200           skip regexp comments
1201           skip # initiated comments in //x patterns
1202           check for embedded @foo
1203           check for embedded scalars
1204           if (backslash) {
1205               leave intact backslashes from leave (below)
1206               deprecate \1 in strings and sub replacements
1207               handle string-changing backslashes \l \U \Q \E, etc.
1208               switch (what was escaped) {
1209                   handle - in a transliteration (becomes a literal -)
1210                   handle \132 octal characters
1211                   handle 0x15 hex characters
1212                   handle \cV (control V)
1213                   handle printf backslashes (\f, \r, \n, etc)
1214               } (end switch)
1215           } (end if backslash)
1216     } (end while character to read)
1217                 
1218 */
1219
1220 STATIC char *
1221 S_scan_const(pTHX_ char *start)
1222 {
1223     register char *send = PL_bufend;            /* end of the constant */
1224     SV *sv = NEWSV(93, send - start);           /* sv for the constant */
1225     register char *s = start;                   /* start of the constant */
1226     register char *d = SvPVX(sv);               /* destination for copies */
1227     bool dorange = FALSE;                       /* are we in a translit range? */
1228     bool didrange = FALSE;                      /* did we just finish a range? */
1229     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1230     I32  this_utf8 = UTF;                       /* The source string is assumed to be UTF8 */
1231     UV uv;
1232
1233     const char *leaveit =       /* set of acceptably-backslashed characters */
1234         PL_lex_inpat
1235             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1236             : "";
1237
1238     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1239         /* If we are doing a trans and we know we want UTF8 set expectation */
1240         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1241         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1242     }
1243
1244
1245     while (s < send || dorange) {
1246         /* get transliterations out of the way (they're most literal) */
1247         if (PL_lex_inwhat == OP_TRANS) {
1248             /* expand a range A-Z to the full set of characters.  AIE! */
1249             if (dorange) {
1250                 I32 i;                          /* current expanded character */
1251                 I32 min;                        /* first character in range */
1252                 I32 max;                        /* last character in range */
1253
1254                 if (has_utf8) {
1255                     char *c = (char*)utf8_hop((U8*)d, -1);
1256                     char *e = d++;
1257                     while (e-- > c)
1258                         *(e + 1) = *e;
1259                     *c = (char)UTF_TO_NATIVE(0xff);
1260                     /* mark the range as done, and continue */
1261                     dorange = FALSE;
1262                     didrange = TRUE;
1263                     continue;
1264                 }
1265
1266                 i = d - SvPVX(sv);              /* remember current offset */
1267                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1268                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1269                 d -= 2;                         /* eat the first char and the - */
1270
1271                 min = (U8)*d;                   /* first char in range */
1272                 max = (U8)d[1];                 /* last char in range  */
1273
1274                 if (min > max) {
1275                     Perl_croak(aTHX_
1276                                "Invalid [] range \"%c-%c\" in transliteration operator",
1277                                (char)min, (char)max);
1278                 }
1279
1280 #ifdef EBCDIC
1281                 if ((isLOWER(min) && isLOWER(max)) ||
1282                     (isUPPER(min) && isUPPER(max))) {
1283                     if (isLOWER(min)) {
1284                         for (i = min; i <= max; i++)
1285                             if (isLOWER(i))
1286                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1287                     } else {
1288                         for (i = min; i <= max; i++)
1289                             if (isUPPER(i))
1290                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1291                     }
1292                 }
1293                 else
1294 #endif
1295                     for (i = min; i <= max; i++)
1296                         *d++ = (char)i;
1297
1298                 /* mark the range as done, and continue */
1299                 dorange = FALSE;
1300                 didrange = TRUE;
1301                 continue;
1302             }
1303
1304             /* range begins (ignore - as first or last char) */
1305             else if (*s == '-' && s+1 < send  && s != start) {
1306                 if (didrange) {
1307                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1308                 }
1309                 if (has_utf8) {
1310                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
1311                     s++;
1312                     continue;
1313                 }
1314                 dorange = TRUE;
1315                 s++;
1316             }
1317             else {
1318                 didrange = FALSE;
1319             }
1320         }
1321
1322         /* if we get here, we're not doing a transliteration */
1323
1324         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1325            except for the last char, which will be done separately. */
1326         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1327             if (s[2] == '#') {
1328                 while (s < send && *s != ')')
1329                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1330             }
1331             else if (s[2] == '{' /* This should match regcomp.c */
1332                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1333             {
1334                 I32 count = 1;
1335                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1336                 char c;
1337
1338                 while (count && (c = *regparse)) {
1339                     if (c == '\\' && regparse[1])
1340                         regparse++;
1341                     else if (c == '{')
1342                         count++;
1343                     else if (c == '}')
1344                         count--;
1345                     regparse++;
1346                 }
1347                 if (*regparse != ')') {
1348                     regparse--;         /* Leave one char for continuation. */
1349                     yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1350                 }
1351                 while (s < regparse)
1352                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1353             }
1354         }
1355
1356         /* likewise skip #-initiated comments in //x patterns */
1357         else if (*s == '#' && PL_lex_inpat &&
1358           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1359             while (s+1 < send && *s != '\n')
1360                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1361         }
1362
1363         /* check for embedded arrays
1364            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1365            */
1366         else if (*s == '@' && s[1]
1367                  && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1368             break;
1369
1370         /* check for embedded scalars.  only stop if we're sure it's a
1371            variable.
1372         */
1373         else if (*s == '$') {
1374             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1375                 break;
1376             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1377                 break;          /* in regexp, $ might be tail anchor */
1378         }
1379
1380         /* End of else if chain - OP_TRANS rejoin rest */
1381
1382         /* backslashes */
1383         if (*s == '\\' && s+1 < send) {
1384             s++;
1385
1386             /* some backslashes we leave behind */
1387             if (*leaveit && *s && strchr(leaveit, *s)) {
1388                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1389                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1390                 continue;
1391             }
1392
1393             /* deprecate \1 in strings and substitution replacements */
1394             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1395                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1396             {
1397                 if (ckWARN(WARN_SYNTAX))
1398                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1399                 *--s = '$';
1400                 break;
1401             }
1402
1403             /* string-change backslash escapes */
1404             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1405                 --s;
1406                 break;
1407             }
1408
1409             /* if we get here, it's either a quoted -, or a digit */
1410             switch (*s) {
1411
1412             /* quoted - in transliterations */
1413             case '-':
1414                 if (PL_lex_inwhat == OP_TRANS) {
1415                     *d++ = *s++;
1416                     continue;
1417                 }
1418                 /* FALL THROUGH */
1419             default:
1420                 {
1421                     if (ckWARN(WARN_MISC) &&
1422                         isALNUM(*s) && 
1423                         *s != '_')
1424                         Perl_warner(aTHX_ packWARN(WARN_MISC),
1425                                "Unrecognized escape \\%c passed through",
1426                                *s);
1427                     /* default action is to copy the quoted character */
1428                     goto default_action;
1429                 }
1430
1431             /* \132 indicates an octal constant */
1432             case '0': case '1': case '2': case '3':
1433             case '4': case '5': case '6': case '7':
1434                 {
1435                     I32 flags = 0;
1436                     STRLEN len = 3;
1437                     uv = grok_oct(s, &len, &flags, NULL);
1438                     s += len;
1439                 }
1440                 goto NUM_ESCAPE_INSERT;
1441
1442             /* \x24 indicates a hex constant */
1443             case 'x':
1444                 ++s;
1445                 if (*s == '{') {
1446                     char* e = strchr(s, '}');
1447                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1448                       PERL_SCAN_DISALLOW_PREFIX;
1449                     STRLEN len;
1450
1451                     ++s;
1452                     if (!e) {
1453                         yyerror("Missing right brace on \\x{}");
1454                         continue;
1455                     }
1456                     len = e - s;
1457                     uv = grok_hex(s, &len, &flags, NULL);
1458                     s = e + 1;
1459                 }
1460                 else {
1461                     {
1462                         STRLEN len = 2;
1463                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1464                         uv = grok_hex(s, &len, &flags, NULL);
1465                         s += len;
1466                     }
1467                 }
1468
1469               NUM_ESCAPE_INSERT:
1470                 /* Insert oct or hex escaped character.
1471                  * There will always enough room in sv since such
1472                  * escapes will be longer than any UTF-8 sequence
1473                  * they can end up as. */
1474                 
1475                 /* We need to map to chars to ASCII before doing the tests
1476                    to cover EBCDIC
1477                 */
1478                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1479                     if (!has_utf8 && uv > 255) {
1480                         /* Might need to recode whatever we have
1481                          * accumulated so far if it contains any
1482                          * hibit chars.
1483                          *
1484                          * (Can't we keep track of that and avoid
1485                          *  this rescan? --jhi)
1486                          */
1487                         int hicount = 0;
1488                         U8 *c;
1489                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1490                             if (!NATIVE_IS_INVARIANT(*c)) {
1491                                 hicount++;
1492                             }
1493                         }
1494                         if (hicount) {
1495                             STRLEN offset = d - SvPVX(sv);
1496                             U8 *src, *dst;
1497                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1498                             src = (U8 *)d - 1;
1499                             dst = src+hicount;
1500                             d  += hicount;
1501                             while (src >= (U8 *)SvPVX(sv)) {
1502                                 if (!NATIVE_IS_INVARIANT(*src)) {
1503                                     U8 ch = NATIVE_TO_ASCII(*src);
1504                                     *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1505                                     *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1506                                 }
1507                                 else {
1508                                     *dst-- = *src;
1509                                 }
1510                                 src--;
1511                             }
1512                         }
1513                     }
1514
1515                     if (has_utf8 || uv > 255) {
1516                         d = (char*)uvchr_to_utf8((U8*)d, uv);
1517                         has_utf8 = TRUE;
1518                         if (PL_lex_inwhat == OP_TRANS &&
1519                             PL_sublex_info.sub_op) {
1520                             PL_sublex_info.sub_op->op_private |=
1521                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
1522                                              : OPpTRANS_TO_UTF);
1523                         }
1524                     }
1525                     else {
1526                         *d++ = (char)uv;
1527                     }
1528                 }
1529                 else {
1530                     *d++ = (char) uv;
1531                 }
1532                 continue;
1533
1534             /* \N{LATIN SMALL LETTER A} is a named character */
1535             case 'N':
1536                 ++s;
1537                 if (*s == '{') {
1538                     char* e = strchr(s, '}');
1539                     SV *res;
1540                     STRLEN len;
1541                     char *str;
1542
1543                     if (!e) {
1544                         yyerror("Missing right brace on \\N{}");
1545                         e = s - 1;
1546                         goto cont_scan;
1547                     }
1548                     if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1549                         /* \N{U+...} */
1550                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1551                           PERL_SCAN_DISALLOW_PREFIX;
1552                         s += 3;
1553                         len = e - s;
1554                         uv = grok_hex(s, &len, &flags, NULL);
1555                         s = e + 1;
1556                         goto NUM_ESCAPE_INSERT;
1557                     }
1558                     res = newSVpvn(s + 1, e - s - 1);
1559                     res = new_constant( Nullch, 0, "charnames",
1560                                         res, Nullsv, "\\N{...}" );
1561                     if (has_utf8)
1562                         sv_utf8_upgrade(res);
1563                     str = SvPV(res,len);
1564 #ifdef EBCDIC_NEVER_MIND
1565                     /* charnames uses pack U and that has been
1566                      * recently changed to do the below uni->native
1567                      * mapping, so this would be redundant (and wrong,
1568                      * the code point would be doubly converted).
1569                      * But leave this in just in case the pack U change
1570                      * gets revoked, but the semantics is still
1571                      * desireable for charnames. --jhi */
1572                     {
1573                          UV uv = utf8_to_uvchr((U8*)str, 0);
1574
1575                          if (uv < 0x100) {
1576                               U8 tmpbuf[UTF8_MAXLEN+1], *d;
1577
1578                               d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1579                               sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1580                               str = SvPV(res, len);
1581                          }
1582                     }
1583 #endif
1584                     if (!has_utf8 && SvUTF8(res)) {
1585                         char *ostart = SvPVX(sv);
1586                         SvCUR_set(sv, d - ostart);
1587                         SvPOK_on(sv);
1588                         *d = '\0';
1589                         sv_utf8_upgrade(sv);
1590                         /* this just broke our allocation above... */
1591                         SvGROW(sv, (STRLEN)(send - start));
1592                         d = SvPVX(sv) + SvCUR(sv);
1593                         has_utf8 = TRUE;
1594                     }
1595                     if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1596                         char *odest = SvPVX(sv);
1597
1598                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1599                         d = SvPVX(sv) + (d - odest);
1600                     }
1601                     Copy(str, d, len, char);
1602                     d += len;
1603                     SvREFCNT_dec(res);
1604                   cont_scan:
1605                     s = e + 1;
1606                 }
1607                 else
1608                     yyerror("Missing braces on \\N{}");
1609                 continue;
1610
1611             /* \c is a control character */
1612             case 'c':
1613                 s++;
1614                 {
1615                     U8 c = *s++;
1616 #ifdef EBCDIC
1617                     if (isLOWER(c))
1618                         c = toUPPER(c);
1619 #endif
1620                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1621                 }
1622                 continue;
1623
1624             /* printf-style backslashes, formfeeds, newlines, etc */
1625             case 'b':
1626                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1627                 break;
1628             case 'n':
1629                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1630                 break;
1631             case 'r':
1632                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1633                 break;
1634             case 'f':
1635                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1636                 break;
1637             case 't':
1638                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1639                 break;
1640             case 'e':
1641                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1642                 break;
1643             case 'a':
1644                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1645                 break;
1646             } /* end switch */
1647
1648             s++;
1649             continue;
1650         } /* end if (backslash) */
1651
1652     default_action:
1653         /* If we started with encoded form, or already know we want it
1654            and then encode the next character */
1655         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1656             STRLEN len  = 1;
1657             UV uv       = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1658             STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1659             s += len;
1660             if (need > len) {
1661                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1662                 STRLEN off = d - SvPVX(sv);
1663                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1664             }
1665             d = (char*)uvchr_to_utf8((U8*)d, uv);
1666             has_utf8 = TRUE;
1667         }
1668         else {
1669             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1670         }
1671     } /* while loop to process each character */
1672
1673     /* terminate the string and set up the sv */
1674     *d = '\0';
1675     SvCUR_set(sv, d - SvPVX(sv));
1676     if (SvCUR(sv) >= SvLEN(sv))
1677       Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1678
1679     SvPOK_on(sv);
1680     if (PL_encoding && !has_utf8) {
1681         sv_recode_to_utf8(sv, PL_encoding);
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
2208     /* check if there's an identifier for us to look at */
2209     if (PL_pending_ident)
2210         return S_pending_ident(aTHX);
2211
2212     /* no identifier pending identification */
2213
2214     switch (PL_lex_state) {
2215 #ifdef COMMENTARY
2216     case LEX_NORMAL:            /* Some compilers will produce faster */
2217     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2218         break;
2219 #endif
2220
2221     /* when we've already built the next token, just pull it out of the queue */
2222     case LEX_KNOWNEXT:
2223         PL_nexttoke--;
2224         yylval = PL_nextval[PL_nexttoke];
2225         if (!PL_nexttoke) {
2226             PL_lex_state = PL_lex_defer;
2227             PL_expect = PL_lex_expect;
2228             PL_lex_defer = LEX_NORMAL;
2229         }
2230         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2231               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2232               (IV)PL_nexttype[PL_nexttoke]); });
2233
2234         return(PL_nexttype[PL_nexttoke]);
2235
2236     /* interpolated case modifiers like \L \U, including \Q and \E.
2237        when we get here, PL_bufptr is at the \
2238     */
2239     case LEX_INTERPCASEMOD:
2240 #ifdef DEBUGGING
2241         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2242             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2243 #endif
2244         /* handle \E or end of string */
2245         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2246             char oldmod;
2247
2248             /* if at a \E */
2249             if (PL_lex_casemods) {
2250                 oldmod = PL_lex_casestack[--PL_lex_casemods];
2251                 PL_lex_casestack[PL_lex_casemods] = '\0';
2252
2253                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2254                     PL_bufptr += 2;
2255                     PL_lex_state = LEX_INTERPCONCAT;
2256                 }
2257                 return ')';
2258             }
2259             if (PL_bufptr != PL_bufend)
2260                 PL_bufptr += 2;
2261             PL_lex_state = LEX_INTERPCONCAT;
2262             return yylex();
2263         }
2264         else {
2265             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2266               "### Saw case modifier at '%s'\n", PL_bufptr); });
2267             s = PL_bufptr + 1;
2268             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2269                 tmp = *s, *s = s[2], s[2] = (char)tmp;  /* misordered... */
2270             if (strchr("LU", *s) &&
2271                 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2272             {
2273                 PL_lex_casestack[--PL_lex_casemods] = '\0';
2274                 return ')';
2275             }
2276             if (PL_lex_casemods > 10) {
2277                 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2278                 if (newlb != PL_lex_casestack) {
2279                     SAVEFREEPV(newlb);
2280                     PL_lex_casestack = newlb;
2281                 }
2282             }
2283             PL_lex_casestack[PL_lex_casemods++] = *s;
2284             PL_lex_casestack[PL_lex_casemods] = '\0';
2285             PL_lex_state = LEX_INTERPCONCAT;
2286             PL_nextval[PL_nexttoke].ival = 0;
2287             force_next('(');
2288             if (*s == 'l')
2289                 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2290             else if (*s == 'u')
2291                 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2292             else if (*s == 'L')
2293                 PL_nextval[PL_nexttoke].ival = OP_LC;
2294             else if (*s == 'U')
2295                 PL_nextval[PL_nexttoke].ival = OP_UC;
2296             else if (*s == 'Q')
2297                 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2298             else
2299                 Perl_croak(aTHX_ "panic: yylex");
2300             PL_bufptr = s + 1;
2301             force_next(FUNC);
2302             if (PL_lex_starts) {
2303                 s = PL_bufptr;
2304                 PL_lex_starts = 0;
2305                 Aop(OP_CONCAT);
2306             }
2307             else
2308                 return yylex();
2309         }
2310
2311     case LEX_INTERPPUSH:
2312         return sublex_push();
2313
2314     case LEX_INTERPSTART:
2315         if (PL_bufptr == PL_bufend)
2316             return sublex_done();
2317         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2318               "### Interpolated variable at '%s'\n", PL_bufptr); });
2319         PL_expect = XTERM;
2320         PL_lex_dojoin = (*PL_bufptr == '@');
2321         PL_lex_state = LEX_INTERPNORMAL;
2322         if (PL_lex_dojoin) {
2323             PL_nextval[PL_nexttoke].ival = 0;
2324             force_next(',');
2325 #ifdef USE_5005THREADS
2326             PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2327             PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2328             force_next(PRIVATEREF);
2329 #else
2330             force_ident("\"", '$');
2331 #endif /* USE_5005THREADS */
2332             PL_nextval[PL_nexttoke].ival = 0;
2333             force_next('$');
2334             PL_nextval[PL_nexttoke].ival = 0;
2335             force_next('(');
2336             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2337             force_next(FUNC);
2338         }
2339         if (PL_lex_starts++) {
2340             s = PL_bufptr;
2341             Aop(OP_CONCAT);
2342         }
2343         return yylex();
2344
2345     case LEX_INTERPENDMAYBE:
2346         if (intuit_more(PL_bufptr)) {
2347             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2348             break;
2349         }
2350         /* FALL THROUGH */
2351
2352     case LEX_INTERPEND:
2353         if (PL_lex_dojoin) {
2354             PL_lex_dojoin = FALSE;
2355             PL_lex_state = LEX_INTERPCONCAT;
2356             return ')';
2357         }
2358         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2359             && SvEVALED(PL_lex_repl))
2360         {
2361             if (PL_bufptr != PL_bufend)
2362                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2363             PL_lex_repl = Nullsv;
2364         }
2365         /* FALLTHROUGH */
2366     case LEX_INTERPCONCAT:
2367 #ifdef DEBUGGING
2368         if (PL_lex_brackets)
2369             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2370 #endif
2371         if (PL_bufptr == PL_bufend)
2372             return sublex_done();
2373
2374         if (SvIVX(PL_linestr) == '\'') {
2375             SV *sv = newSVsv(PL_linestr);
2376             if (!PL_lex_inpat)
2377                 sv = tokeq(sv);
2378             else if ( PL_hints & HINT_NEW_RE )
2379                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2380             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2381             s = PL_bufend;
2382         }
2383         else {
2384             s = scan_const(PL_bufptr);
2385             if (*s == '\\')
2386                 PL_lex_state = LEX_INTERPCASEMOD;
2387             else
2388                 PL_lex_state = LEX_INTERPSTART;
2389         }
2390
2391         if (s != PL_bufptr) {
2392             PL_nextval[PL_nexttoke] = yylval;
2393             PL_expect = XTERM;
2394             force_next(THING);
2395             if (PL_lex_starts++)
2396                 Aop(OP_CONCAT);
2397             else {
2398                 PL_bufptr = s;
2399                 return yylex();
2400             }
2401         }
2402
2403         return yylex();
2404     case LEX_FORMLINE:
2405         PL_lex_state = LEX_NORMAL;
2406         s = scan_formline(PL_bufptr);
2407         if (!PL_lex_formbrack)
2408             goto rightbracket;
2409         OPERATOR(';');
2410     }
2411
2412     s = PL_bufptr;
2413     PL_oldoldbufptr = PL_oldbufptr;
2414     PL_oldbufptr = s;
2415     DEBUG_T( {
2416         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2417                       exp_name[PL_expect], s);
2418     } );
2419
2420   retry:
2421     switch (*s) {
2422     default:
2423         if (isIDFIRST_lazy_if(s,UTF))
2424             goto keylookup;
2425         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2426     case 4:
2427     case 26:
2428         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2429     case 0:
2430         if (!PL_rsfp) {
2431             PL_last_uni = 0;
2432             PL_last_lop = 0;
2433             if (PL_lex_brackets)
2434                 yyerror("Missing right curly or square bracket");
2435             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2436                         "### Tokener got EOF\n");
2437             } );
2438             TOKEN(0);
2439         }
2440         if (s++ < PL_bufend)
2441             goto retry;                 /* ignore stray nulls */
2442         PL_last_uni = 0;
2443         PL_last_lop = 0;
2444         if (!PL_in_eval && !PL_preambled) {
2445             PL_preambled = TRUE;
2446             sv_setpv(PL_linestr,incl_perldb());
2447             if (SvCUR(PL_linestr))
2448                 sv_catpv(PL_linestr,";");
2449             if (PL_preambleav){
2450                 while(AvFILLp(PL_preambleav) >= 0) {
2451                     SV *tmpsv = av_shift(PL_preambleav);
2452                     sv_catsv(PL_linestr, tmpsv);
2453                     sv_catpv(PL_linestr, ";");
2454                     sv_free(tmpsv);
2455                 }
2456                 sv_free((SV*)PL_preambleav);
2457                 PL_preambleav = NULL;
2458             }
2459             if (PL_minus_n || PL_minus_p) {
2460                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2461                 if (PL_minus_l)
2462                     sv_catpv(PL_linestr,"chomp;");
2463                 if (PL_minus_a) {
2464                     if (PL_minus_F) {
2465                         if (strchr("/'\"", *PL_splitstr)
2466                               && strchr(PL_splitstr + 1, *PL_splitstr))
2467                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2468                         else {
2469                             char delim;
2470                             s = "'~#\200\1'"; /* surely one char is unused...*/
2471                             while (s[1] && strchr(PL_splitstr, *s))  s++;
2472                             delim = *s;
2473                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2474                                       "q" + (delim == '\''), delim);
2475                             for (s = PL_splitstr; *s; s++) {
2476                                 if (*s == '\\')
2477                                     sv_catpvn(PL_linestr, "\\", 1);
2478                                 sv_catpvn(PL_linestr, s, 1);
2479                             }
2480                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2481                         }
2482                     }
2483                     else
2484                         sv_catpv(PL_linestr,"our @F=split(' ');");
2485                 }
2486             }
2487             sv_catpv(PL_linestr, "\n");
2488             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2489             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2490             PL_last_lop = PL_last_uni = Nullch;
2491             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2492                 SV *sv = NEWSV(85,0);
2493
2494                 sv_upgrade(sv, SVt_PVMG);
2495                 sv_setsv(sv,PL_linestr);
2496                 (void)SvIOK_on(sv);
2497                 SvIVX(sv) = 0;
2498                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2499             }
2500             goto retry;
2501         }
2502         do {
2503             bof = PL_rsfp ? TRUE : FALSE;
2504             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2505               fake_eof:
2506                 if (PL_rsfp) {
2507                     if (PL_preprocess && !PL_in_eval)
2508                         (void)PerlProc_pclose(PL_rsfp);
2509                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2510                         PerlIO_clearerr(PL_rsfp);
2511                     else
2512                         (void)PerlIO_close(PL_rsfp);
2513                     PL_rsfp = Nullfp;
2514                     PL_doextract = FALSE;
2515                 }
2516                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2517                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2518                     sv_catpv(PL_linestr,";}");
2519                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2520                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2521                     PL_last_lop = PL_last_uni = Nullch;
2522                     PL_minus_n = PL_minus_p = 0;
2523                     goto retry;
2524                 }
2525                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2526                 PL_last_lop = PL_last_uni = Nullch;
2527                 sv_setpv(PL_linestr,"");
2528                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2529             }
2530             /* if it looks like the start of a BOM, check if it in fact is */
2531             else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2532 #ifdef PERLIO_IS_STDIO
2533 #  ifdef __GNU_LIBRARY__
2534 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2535 #      define FTELL_FOR_PIPE_IS_BROKEN
2536 #    endif
2537 #  else
2538 #    ifdef __GLIBC__
2539 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2540 #        define FTELL_FOR_PIPE_IS_BROKEN
2541 #      endif
2542 #    endif
2543 #  endif
2544 #endif
2545 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2546                 /* This loses the possibility to detect the bof
2547                  * situation on perl -P when the libc5 is being used.
2548                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2549                  */
2550                 if (!PL_preprocess)
2551                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2552 #else
2553                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2554 #endif
2555                 if (bof) {
2556                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2557                     s = swallow_bom((U8*)s);
2558                 }
2559             }
2560             if (PL_doextract) {
2561                 /* Incest with pod. */
2562                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2563                     sv_setpv(PL_linestr, "");
2564                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2565                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2566                     PL_last_lop = PL_last_uni = Nullch;
2567                     PL_doextract = FALSE;
2568                 }
2569             }
2570             incline(s);
2571         } while (PL_doextract);
2572         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2573         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2574             SV *sv = NEWSV(85,0);
2575
2576             sv_upgrade(sv, SVt_PVMG);
2577             sv_setsv(sv,PL_linestr);
2578             (void)SvIOK_on(sv);
2579             SvIVX(sv) = 0;
2580             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2581         }
2582         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2583         PL_last_lop = PL_last_uni = Nullch;
2584         if (CopLINE(PL_curcop) == 1) {
2585             while (s < PL_bufend && isSPACE(*s))
2586                 s++;
2587             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2588                 s++;
2589             d = Nullch;
2590             if (!PL_in_eval) {
2591                 if (*s == '#' && *(s+1) == '!')
2592                     d = s + 2;
2593 #ifdef ALTERNATE_SHEBANG
2594                 else {
2595                     static char as[] = ALTERNATE_SHEBANG;
2596                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2597                         d = s + (sizeof(as) - 1);
2598                 }
2599 #endif /* ALTERNATE_SHEBANG */
2600             }
2601             if (d) {
2602                 char *ipath;
2603                 char *ipathend;
2604
2605                 while (isSPACE(*d))
2606                     d++;
2607                 ipath = d;
2608                 while (*d && !isSPACE(*d))
2609                     d++;
2610                 ipathend = d;
2611
2612 #ifdef ARG_ZERO_IS_SCRIPT
2613                 if (ipathend > ipath) {
2614                     /*
2615                      * HP-UX (at least) sets argv[0] to the script name,
2616                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2617                      * at least, set argv[0] to the basename of the Perl
2618                      * interpreter. So, having found "#!", we'll set it right.
2619                      */
2620                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2621                     assert(SvPOK(x) || SvGMAGICAL(x));
2622                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2623                         sv_setpvn(x, ipath, ipathend - ipath);
2624                         SvSETMAGIC(x);
2625                     }
2626                     else {
2627                         STRLEN blen;
2628                         STRLEN llen;
2629                         char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2630                         char *lstart = SvPV(x,llen);
2631                         if (llen < blen) {
2632                             bstart += blen - llen;
2633                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2634                                 sv_setpvn(x, ipath, ipathend - ipath);
2635                                 SvSETMAGIC(x);
2636                             }
2637                         }
2638                     }
2639                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2640                 }
2641 #endif /* ARG_ZERO_IS_SCRIPT */
2642
2643                 /*
2644                  * Look for options.
2645                  */
2646                 d = instr(s,"perl -");
2647                 if (!d) {
2648                     d = instr(s,"perl");
2649 #if defined(DOSISH)
2650                     /* avoid getting into infinite loops when shebang
2651                      * line contains "Perl" rather than "perl" */
2652                     if (!d) {
2653                         for (d = ipathend-4; d >= ipath; --d) {
2654                             if ((*d == 'p' || *d == 'P')
2655                                 && !ibcmp(d, "perl", 4))
2656                             {
2657                                 break;
2658                             }
2659                         }
2660                         if (d < ipath)
2661                             d = Nullch;
2662                     }
2663 #endif
2664                 }
2665 #ifdef ALTERNATE_SHEBANG
2666                 /*
2667                  * If the ALTERNATE_SHEBANG on this system starts with a
2668                  * character that can be part of a Perl expression, then if
2669                  * we see it but not "perl", we're probably looking at the
2670                  * start of Perl code, not a request to hand off to some
2671                  * other interpreter.  Similarly, if "perl" is there, but
2672                  * not in the first 'word' of the line, we assume the line
2673                  * contains the start of the Perl program.
2674                  */
2675                 if (d && *s != '#') {
2676                     char *c = ipath;
2677                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2678                         c++;
2679                     if (c < d)
2680                         d = Nullch;     /* "perl" not in first word; ignore */
2681                     else
2682                         *s = '#';       /* Don't try to parse shebang line */
2683                 }
2684 #endif /* ALTERNATE_SHEBANG */
2685 #ifndef MACOS_TRADITIONAL
2686                 if (!d &&
2687                     *s == '#' &&
2688                     ipathend > ipath &&
2689                     !PL_minus_c &&
2690                     !instr(s,"indir") &&
2691                     instr(PL_origargv[0],"perl"))
2692                 {
2693                     char **newargv;
2694
2695                     *ipathend = '\0';
2696                     s = ipathend + 1;
2697                     while (s < PL_bufend && isSPACE(*s))
2698                         s++;
2699                     if (s < PL_bufend) {
2700                         Newz(899,newargv,PL_origargc+3,char*);
2701                         newargv[1] = s;
2702                         while (s < PL_bufend && !isSPACE(*s))
2703                             s++;
2704                         *s = '\0';
2705                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2706                     }
2707                     else
2708                         newargv = PL_origargv;
2709                     newargv[0] = ipath;
2710                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2711                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2712                 }
2713 #endif
2714                 if (d) {
2715                     U32 oldpdb = PL_perldb;
2716                     bool oldn = PL_minus_n;
2717                     bool oldp = PL_minus_p;
2718
2719                     while (*d && !isSPACE(*d)) d++;
2720                     while (SPACE_OR_TAB(*d)) d++;
2721
2722                     if (*d++ == '-') {
2723                         bool switches_done = PL_doswitches;
2724                         do {
2725                             if (*d == 'M' || *d == 'm') {
2726                                 char *m = d;
2727                                 while (*d && !isSPACE(*d)) d++;
2728                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2729                                       (int)(d - m), m);
2730                             }
2731                             d = moreswitches(d);
2732                         } while (d);
2733                         if ((PERLDB_LINE && !oldpdb) ||
2734                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2735                               /* if we have already added "LINE: while (<>) {",
2736                                  we must not do it again */
2737                         {
2738                             sv_setpv(PL_linestr, "");
2739                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2740                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2741                             PL_last_lop = PL_last_uni = Nullch;
2742                             PL_preambled = FALSE;
2743                             if (PERLDB_LINE)
2744                                 (void)gv_fetchfile(PL_origfilename);
2745                             goto retry;
2746                         }
2747                         if (PL_doswitches && !switches_done) {
2748                             int argc = PL_origargc;
2749                             char **argv = PL_origargv;
2750                             do {
2751                                 argc--,argv++;
2752                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2753                             init_argv_symbols(argc,argv);
2754                         }
2755                     }
2756                 }
2757             }
2758         }
2759         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2760             PL_bufptr = s;
2761             PL_lex_state = LEX_FORMLINE;
2762             return yylex();
2763         }
2764         goto retry;
2765     case '\r':
2766 #ifdef PERL_STRICT_CR
2767         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2768         Perl_croak(aTHX_
2769       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2770 #endif
2771     case ' ': case '\t': case '\f': case 013:
2772 #ifdef MACOS_TRADITIONAL
2773     case '\312':
2774 #endif
2775         s++;
2776         goto retry;
2777     case '#':
2778     case '\n':
2779         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2780             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2781                 /* handle eval qq[#line 1 "foo"\n ...] */
2782                 CopLINE_dec(PL_curcop);
2783                 incline(s);
2784             }
2785             d = PL_bufend;
2786             while (s < d && *s != '\n')
2787                 s++;
2788             if (s < d)
2789                 s++;
2790             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2791               Perl_croak(aTHX_ "panic: input overflow");
2792             incline(s);
2793             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2794                 PL_bufptr = s;
2795                 PL_lex_state = LEX_FORMLINE;
2796                 return yylex();
2797             }
2798         }
2799         else {
2800             *s = '\0';
2801             PL_bufend = s;
2802         }
2803         goto retry;
2804     case '-':
2805         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2806             I32 ftst = 0;
2807
2808             s++;
2809             PL_bufptr = s;
2810             tmp = *s++;
2811
2812             while (s < PL_bufend && SPACE_OR_TAB(*s))
2813                 s++;
2814
2815             if (strnEQ(s,"=>",2)) {
2816                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2817                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2818                             "### Saw unary minus before =>, forcing word '%s'\n", s);
2819                 } );
2820                 OPERATOR('-');          /* unary minus */
2821             }
2822             PL_last_uni = PL_oldbufptr;
2823             switch (tmp) {
2824             case 'r': ftst = OP_FTEREAD;        break;
2825             case 'w': ftst = OP_FTEWRITE;       break;
2826             case 'x': ftst = OP_FTEEXEC;        break;
2827             case 'o': ftst = OP_FTEOWNED;       break;
2828             case 'R': ftst = OP_FTRREAD;        break;
2829             case 'W': ftst = OP_FTRWRITE;       break;
2830             case 'X': ftst = OP_FTREXEC;        break;
2831             case 'O': ftst = OP_FTROWNED;       break;
2832             case 'e': ftst = OP_FTIS;           break;
2833             case 'z': ftst = OP_FTZERO;         break;
2834             case 's': ftst = OP_FTSIZE;         break;
2835             case 'f': ftst = OP_FTFILE;         break;
2836             case 'd': ftst = OP_FTDIR;          break;
2837             case 'l': ftst = OP_FTLINK;         break;
2838             case 'p': ftst = OP_FTPIPE;         break;
2839             case 'S': ftst = OP_FTSOCK;         break;
2840             case 'u': ftst = OP_FTSUID;         break;
2841             case 'g': ftst = OP_FTSGID;         break;
2842             case 'k': ftst = OP_FTSVTX;         break;
2843             case 'b': ftst = OP_FTBLK;          break;
2844             case 'c': ftst = OP_FTCHR;          break;
2845             case 't': ftst = OP_FTTTY;          break;
2846             case 'T': ftst = OP_FTTEXT;         break;
2847             case 'B': ftst = OP_FTBINARY;       break;
2848             case 'M': case 'A': case 'C':
2849                 gv_fetchpv("\024",TRUE, SVt_PV);
2850                 switch (tmp) {
2851                 case 'M': ftst = OP_FTMTIME;    break;
2852                 case 'A': ftst = OP_FTATIME;    break;
2853                 case 'C': ftst = OP_FTCTIME;    break;
2854                 default:                        break;
2855                 }
2856                 break;
2857             default:
2858                 break;
2859             }
2860             if (ftst) {
2861                 PL_last_lop_op = (OPCODE)ftst;
2862                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2863                         "### Saw file test %c\n", (int)ftst);
2864                 } );
2865                 FTST(ftst);
2866             }
2867             else {
2868                 /* Assume it was a minus followed by a one-letter named
2869                  * subroutine call (or a -bareword), then. */
2870                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2871                         "### %c looked like a file test but was not\n",
2872                         (int)ftst);
2873                 } );
2874                 s -= 2;
2875             }
2876         }
2877         tmp = *s++;
2878         if (*s == tmp) {
2879             s++;
2880             if (PL_expect == XOPERATOR)
2881                 TERM(POSTDEC);
2882             else
2883                 OPERATOR(PREDEC);
2884         }
2885         else if (*s == '>') {
2886             s++;
2887             s = skipspace(s);
2888             if (isIDFIRST_lazy_if(s,UTF)) {
2889                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2890                 TOKEN(ARROW);
2891             }
2892             else if (*s == '$')
2893                 OPERATOR(ARROW);
2894             else
2895                 TERM(ARROW);
2896         }
2897         if (PL_expect == XOPERATOR)
2898             Aop(OP_SUBTRACT);
2899         else {
2900             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2901                 check_uni();
2902             OPERATOR('-');              /* unary minus */
2903         }
2904
2905     case '+':
2906         tmp = *s++;
2907         if (*s == tmp) {
2908             s++;
2909             if (PL_expect == XOPERATOR)
2910                 TERM(POSTINC);
2911             else
2912                 OPERATOR(PREINC);
2913         }
2914         if (PL_expect == XOPERATOR)
2915             Aop(OP_ADD);
2916         else {
2917             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2918                 check_uni();
2919             OPERATOR('+');
2920         }
2921
2922     case '*':
2923         if (PL_expect != XOPERATOR) {
2924             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2925             PL_expect = XOPERATOR;
2926             force_ident(PL_tokenbuf, '*');
2927             if (!*PL_tokenbuf)
2928                 PREREF('*');
2929             TERM('*');
2930         }
2931         s++;
2932         if (*s == '*') {
2933             s++;
2934             PWop(OP_POW);
2935         }
2936         Mop(OP_MULTIPLY);
2937
2938     case '%':
2939         if (PL_expect == XOPERATOR) {
2940             ++s;
2941             Mop(OP_MODULO);
2942         }
2943         PL_tokenbuf[0] = '%';
2944         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2945         if (!PL_tokenbuf[1]) {
2946             if (s == PL_bufend)
2947                 yyerror("Final % should be \\% or %name");
2948             PREREF('%');
2949         }
2950         PL_pending_ident = '%';
2951         TERM('%');
2952
2953     case '^':
2954         s++;
2955         BOop(OP_BIT_XOR);
2956     case '[':
2957         PL_lex_brackets++;
2958         /* FALL THROUGH */
2959     case '~':
2960     case ',':
2961         tmp = *s++;
2962         OPERATOR(tmp);
2963     case ':':
2964         if (s[1] == ':') {
2965             len = 0;
2966             goto just_a_word;
2967         }
2968         s++;
2969         switch (PL_expect) {
2970             OP *attrs;
2971         case XOPERATOR:
2972             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2973                 break;
2974             PL_bufptr = s;      /* update in case we back off */
2975             goto grabattrs;
2976         case XATTRBLOCK:
2977             PL_expect = XBLOCK;
2978             goto grabattrs;
2979         case XATTRTERM:
2980             PL_expect = XTERMBLOCK;
2981          grabattrs:
2982             s = skipspace(s);
2983             attrs = Nullop;
2984             while (isIDFIRST_lazy_if(s,UTF)) {
2985                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2986                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2987                     if (tmp < 0) tmp = -tmp;
2988                     switch (tmp) {
2989                     case KEY_or:
2990                     case KEY_and:
2991                     case KEY_err:
2992                     case KEY_for:
2993                     case KEY_unless:
2994                     case KEY_if:
2995                     case KEY_while:
2996                     case KEY_until:
2997                         goto got_attrs;
2998                     default:
2999                         break;
3000                     }
3001                 }
3002                 if (*d == '(') {
3003                     d = scan_str(d,TRUE,TRUE);
3004                     if (!d) {
3005                         /* MUST advance bufptr here to avoid bogus
3006                            "at end of line" context messages from yyerror().
3007                          */
3008                         PL_bufptr = s + len;
3009                         yyerror("Unterminated attribute parameter in attribute list");
3010                         if (attrs)
3011                             op_free(attrs);
3012                         return 0;       /* EOF indicator */
3013                     }
3014                 }
3015                 if (PL_lex_stuff) {
3016                     SV *sv = newSVpvn(s, len);
3017                     sv_catsv(sv, PL_lex_stuff);
3018                     attrs = append_elem(OP_LIST, attrs,
3019                                         newSVOP(OP_CONST, 0, sv));
3020                     SvREFCNT_dec(PL_lex_stuff);
3021                     PL_lex_stuff = Nullsv;
3022                 }
3023                 else {
3024                     /* NOTE: any CV attrs applied here need to be part of
3025                        the CVf_BUILTIN_ATTRS define in cv.h! */
3026                     if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3027                         CvLVALUE_on(PL_compcv);
3028                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3029                         CvLOCKED_on(PL_compcv);
3030                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3031                         CvMETHOD_on(PL_compcv);
3032 #ifdef USE_ITHREADS
3033                     else if (PL_in_my == KEY_our && len == 6 &&
3034                              strnEQ(s, "unique", len))
3035                         GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3036 #endif
3037                     /* After we've set the flags, it could be argued that
3038                        we don't need to do the attributes.pm-based setting
3039                        process, and shouldn't bother appending recognized
3040                        flags.  To experiment with that, uncomment the
3041                        following "else".  (Note that's already been
3042                        uncommented.  That keeps the above-applied built-in
3043                        attributes from being intercepted (and possibly
3044                        rejected) by a package's attribute routines, but is
3045                        justified by the performance win for the common case
3046                        of applying only built-in attributes.) */
3047                     else
3048                         attrs = append_elem(OP_LIST, attrs,
3049                                             newSVOP(OP_CONST, 0,
3050                                                     newSVpvn(s, len)));
3051                 }
3052                 s = skipspace(d);
3053                 if (*s == ':' && s[1] != ':')
3054                     s = skipspace(s+1);
3055                 else if (s == d)
3056                     break;      /* require real whitespace or :'s */
3057             }
3058             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3059             if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3060                 char q = ((*s == '\'') ? '"' : '\'');
3061                 /* If here for an expression, and parsed no attrs, back off. */
3062                 if (tmp == '=' && !attrs) {
3063                     s = PL_bufptr;
3064                     break;
3065                 }
3066                 /* MUST advance bufptr here to avoid bogus "at end of line"
3067                    context messages from yyerror().
3068                  */
3069                 PL_bufptr = s;
3070                 if (!*s)
3071                     yyerror("Unterminated attribute list");
3072                 else
3073                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3074                                       q, *s, q));
3075                 if (attrs)
3076                     op_free(attrs);
3077                 OPERATOR(':');
3078             }
3079         got_attrs:
3080             if (attrs) {
3081                 PL_nextval[PL_nexttoke].opval = attrs;
3082                 force_next(THING);
3083             }
3084             TOKEN(COLONATTR);
3085         }
3086         OPERATOR(':');
3087     case '(':
3088         s++;
3089         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3090             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3091         else
3092             PL_expect = XTERM;
3093         TOKEN('(');
3094     case ';':
3095         CLINE;
3096         tmp = *s++;
3097         OPERATOR(tmp);
3098     case ')':
3099         tmp = *s++;
3100         s = skipspace(s);
3101         if (*s == '{')
3102             PREBLOCK(tmp);
3103         TERM(tmp);
3104     case ']':
3105         s++;
3106         if (PL_lex_brackets <= 0)
3107             yyerror("Unmatched right square bracket");
3108         else
3109             --PL_lex_brackets;
3110         if (PL_lex_state == LEX_INTERPNORMAL) {
3111             if (PL_lex_brackets == 0) {
3112                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3113                     PL_lex_state = LEX_INTERPEND;
3114             }
3115         }
3116         TERM(']');
3117     case '{':
3118       leftbracket:
3119         s++;
3120         if (PL_lex_brackets > 100) {
3121             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3122             if (newlb != PL_lex_brackstack) {
3123                 SAVEFREEPV(newlb);
3124                 PL_lex_brackstack = newlb;
3125             }
3126         }
3127         switch (PL_expect) {
3128         case XTERM:
3129             if (PL_lex_formbrack) {
3130                 s--;
3131                 PRETERMBLOCK(DO);
3132             }
3133             if (PL_oldoldbufptr == PL_last_lop)
3134                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3135             else
3136                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3137             OPERATOR(HASHBRACK);
3138         case XOPERATOR:
3139             while (s < PL_bufend && SPACE_OR_TAB(*s))
3140                 s++;
3141             d = s;
3142             PL_tokenbuf[0] = '\0';
3143             if (d < PL_bufend && *d == '-') {
3144                 PL_tokenbuf[0] = '-';
3145                 d++;
3146                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3147                     d++;
3148             }
3149             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3150                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3151                               FALSE, &len);
3152                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3153                     d++;
3154                 if (*d == '}') {
3155                     char minus = (PL_tokenbuf[0] == '-');
3156                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3157                     if (minus)
3158                         force_next('-');
3159                 }
3160             }
3161             /* FALL THROUGH */
3162         case XATTRBLOCK:
3163         case XBLOCK:
3164             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3165             PL_expect = XSTATE;
3166             break;
3167         case XATTRTERM:
3168         case XTERMBLOCK:
3169             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3170             PL_expect = XSTATE;
3171             break;
3172         default: {
3173                 char *t;
3174                 if (PL_oldoldbufptr == PL_last_lop)
3175                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3176                 else
3177                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3178                 s = skipspace(s);
3179                 if (*s == '}') {
3180                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3181                         PL_expect = XTERM;
3182                         /* This hack is to get the ${} in the message. */
3183                         PL_bufptr = s+1;
3184                         yyerror("syntax error");
3185                         break;
3186                     }
3187                     OPERATOR(HASHBRACK);
3188                 }
3189                 /* This hack serves to disambiguate a pair of curlies
3190                  * as being a block or an anon hash.  Normally, expectation
3191                  * determines that, but in cases where we're not in a
3192                  * position to expect anything in particular (like inside
3193                  * eval"") we have to resolve the ambiguity.  This code
3194                  * covers the case where the first term in the curlies is a
3195                  * quoted string.  Most other cases need to be explicitly
3196                  * disambiguated by prepending a `+' before the opening
3197                  * curly in order to force resolution as an anon hash.
3198                  *
3199                  * XXX should probably propagate the outer expectation
3200                  * into eval"" to rely less on this hack, but that could
3201                  * potentially break current behavior of eval"".
3202                  * GSAR 97-07-21
3203                  */
3204                 t = s;
3205                 if (*s == '\'' || *s == '"' || *s == '`') {
3206                     /* common case: get past first string, handling escapes */
3207                     for (t++; t < PL_bufend && *t != *s;)
3208                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3209                             t++;
3210                     t++;
3211                 }
3212                 else if (*s == 'q') {
3213                     if (++t < PL_bufend
3214                         && (!isALNUM(*t)
3215                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3216                                 && !isALNUM(*t))))
3217                     {
3218                         char *tmps;
3219                         char open, close, term;
3220                         I32 brackets = 1;
3221
3222                         while (t < PL_bufend && isSPACE(*t))
3223                             t++;
3224                         term = *t;
3225                         open = term;
3226                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3227                             term = tmps[5];
3228                         close = term;
3229                         if (open == close)
3230                             for (t++; t < PL_bufend; t++) {
3231                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3232                                     t++;
3233                                 else if (*t == open)
3234                                     break;
3235                             }
3236                         else
3237                             for (t++; t < PL_bufend; t++) {
3238                                 if (*t == '\\' && t+1 < PL_bufend)
3239                                     t++;
3240                                 else if (*t == close && --brackets <= 0)
3241                                     break;
3242                                 else if (*t == open)
3243                                     brackets++;
3244                             }
3245                     }
3246                     t++;
3247                 }
3248                 else if (isALNUM_lazy_if(t,UTF)) {
3249                     t += UTF8SKIP(t);
3250                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3251                          t += UTF8SKIP(t);
3252                 }
3253                 while (t < PL_bufend && isSPACE(*t))
3254                     t++;
3255                 /* if comma follows first term, call it an anon hash */
3256                 /* XXX it could be a comma expression with loop modifiers */
3257                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3258                                    || (*t == '=' && t[1] == '>')))
3259                     OPERATOR(HASHBRACK);
3260                 if (PL_expect == XREF)
3261                     PL_expect = XTERM;
3262                 else {
3263                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3264                     PL_expect = XSTATE;
3265                 }
3266             }
3267             break;
3268         }
3269         yylval.ival = CopLINE(PL_curcop);
3270         if (isSPACE(*s) || *s == '#')
3271             PL_copline = NOLINE;   /* invalidate current command line number */
3272         TOKEN('{');
3273     case '}':
3274       rightbracket:
3275         s++;
3276         if (PL_lex_brackets <= 0)
3277             yyerror("Unmatched right curly bracket");
3278         else
3279             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3280         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3281             PL_lex_formbrack = 0;
3282         if (PL_lex_state == LEX_INTERPNORMAL) {
3283             if (PL_lex_brackets == 0) {
3284                 if (PL_expect & XFAKEBRACK) {
3285                     PL_expect &= XENUMMASK;
3286                     PL_lex_state = LEX_INTERPEND;
3287                     PL_bufptr = s;
3288                     return yylex();     /* ignore fake brackets */
3289                 }
3290                 if (*s == '-' && s[1] == '>')
3291                     PL_lex_state = LEX_INTERPENDMAYBE;
3292                 else if (*s != '[' && *s != '{')
3293                     PL_lex_state = LEX_INTERPEND;
3294             }
3295         }
3296         if (PL_expect & XFAKEBRACK) {
3297             PL_expect &= XENUMMASK;
3298             PL_bufptr = s;
3299             return yylex();             /* ignore fake brackets */
3300         }
3301         force_next('}');
3302         TOKEN(';');
3303     case '&':
3304         s++;
3305         tmp = *s++;
3306         if (tmp == '&')
3307             AOPERATOR(ANDAND);
3308         s--;
3309         if (PL_expect == XOPERATOR) {
3310             if (ckWARN(WARN_SEMICOLON)
3311                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3312             {
3313                 CopLINE_dec(PL_curcop);
3314                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3315                 CopLINE_inc(PL_curcop);
3316             }
3317             BAop(OP_BIT_AND);
3318         }
3319
3320         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3321         if (*PL_tokenbuf) {
3322             PL_expect = XOPERATOR;
3323             force_ident(PL_tokenbuf, '&');
3324         }
3325         else
3326             PREREF('&');
3327         yylval.ival = (OPpENTERSUB_AMPER<<8);
3328         TERM('&');
3329
3330     case '|':
3331         s++;
3332         tmp = *s++;
3333         if (tmp == '|')
3334             AOPERATOR(OROR);
3335         s--;
3336         BOop(OP_BIT_OR);
3337     case '=':
3338         s++;
3339         tmp = *s++;
3340         if (tmp == '=')
3341             Eop(OP_EQ);
3342         if (tmp == '>')
3343             OPERATOR(',');
3344         if (tmp == '~')
3345             PMop(OP_MATCH);
3346         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3347             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3348         s--;
3349         if (PL_expect == XSTATE && isALPHA(tmp) &&
3350                 (s == PL_linestart+1 || s[-2] == '\n') )
3351         {
3352             if (PL_in_eval && !PL_rsfp) {
3353                 d = PL_bufend;
3354                 while (s < d) {
3355                     if (*s++ == '\n') {
3356                         incline(s);
3357                         if (strnEQ(s,"=cut",4)) {
3358                             s = strchr(s,'\n');
3359                             if (s)
3360                                 s++;
3361                             else
3362                                 s = d;
3363                             incline(s);
3364                             goto retry;
3365                         }
3366                     }
3367                 }
3368                 goto retry;
3369             }
3370             s = PL_bufend;
3371             PL_doextract = TRUE;
3372             goto retry;
3373         }
3374         if (PL_lex_brackets < PL_lex_formbrack) {
3375             char *t;
3376 #ifdef PERL_STRICT_CR
3377             for (t = s; SPACE_OR_TAB(*t); t++) ;
3378 #else
3379             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3380 #endif
3381             if (*t == '\n' || *t == '#') {
3382                 s--;
3383                 PL_expect = XBLOCK;
3384                 goto leftbracket;
3385             }
3386         }
3387         yylval.ival = 0;
3388         OPERATOR(ASSIGNOP);
3389     case '!':
3390         s++;
3391         tmp = *s++;
3392         if (tmp == '=')
3393             Eop(OP_NE);
3394         if (tmp == '~')
3395             PMop(OP_NOT);
3396         s--;
3397         OPERATOR('!');
3398     case '<':
3399         if (PL_expect != XOPERATOR) {
3400             if (s[1] != '<' && !strchr(s,'>'))
3401                 check_uni();
3402             if (s[1] == '<')
3403                 s = scan_heredoc(s);
3404             else
3405                 s = scan_inputsymbol(s);
3406             TERM(sublex_start());
3407         }
3408         s++;
3409         tmp = *s++;
3410         if (tmp == '<')
3411             SHop(OP_LEFT_SHIFT);
3412         if (tmp == '=') {
3413             tmp = *s++;
3414             if (tmp == '>')
3415                 Eop(OP_NCMP);
3416             s--;
3417             Rop(OP_LE);
3418         }
3419         s--;
3420         Rop(OP_LT);
3421     case '>':
3422         s++;
3423         tmp = *s++;
3424         if (tmp == '>')
3425             SHop(OP_RIGHT_SHIFT);
3426         if (tmp == '=')
3427             Rop(OP_GE);
3428         s--;
3429         Rop(OP_GT);
3430
3431     case '$':
3432         CLINE;
3433
3434         if (PL_expect == XOPERATOR) {
3435             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3436                 PL_expect = XTERM;
3437                 depcom();
3438                 return ','; /* grandfather non-comma-format format */
3439             }
3440         }
3441
3442         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3443             PL_tokenbuf[0] = '@';
3444             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3445                            sizeof PL_tokenbuf - 1, FALSE);
3446             if (PL_expect == XOPERATOR)
3447                 no_op("Array length", s);
3448             if (!PL_tokenbuf[1])
3449                 PREREF(DOLSHARP);
3450             PL_expect = XOPERATOR;
3451             PL_pending_ident = '#';
3452             TOKEN(DOLSHARP);
3453         }
3454
3455         PL_tokenbuf[0] = '$';
3456         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3457                        sizeof PL_tokenbuf - 1, FALSE);
3458         if (PL_expect == XOPERATOR)
3459             no_op("Scalar", s);
3460         if (!PL_tokenbuf[1]) {
3461             if (s == PL_bufend)
3462                 yyerror("Final $ should be \\$ or $name");
3463             PREREF('$');
3464         }
3465
3466         /* This kludge not intended to be bulletproof. */
3467         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3468             yylval.opval = newSVOP(OP_CONST, 0,
3469                                    newSViv(PL_compiling.cop_arybase));
3470             yylval.opval->op_private = OPpCONST_ARYBASE;
3471             TERM(THING);
3472         }
3473
3474         d = s;
3475         tmp = (I32)*s;
3476         if (PL_lex_state == LEX_NORMAL)
3477             s = skipspace(s);
3478
3479         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3480             char *t;
3481             if (*s == '[') {
3482                 PL_tokenbuf[0] = '@';
3483                 if (ckWARN(WARN_SYNTAX)) {
3484                     for(t = s + 1;
3485                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3486                         t++) ;
3487                     if (*t++ == ',') {
3488                         PL_bufptr = skipspace(PL_bufptr);
3489                         while (t < PL_bufend && *t != ']')
3490                             t++;
3491                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3492                                 "Multidimensional syntax %.*s not supported",
3493                                 (t - PL_bufptr) + 1, PL_bufptr);
3494                     }
3495                 }
3496             }
3497             else if (*s == '{') {
3498                 PL_tokenbuf[0] = '%';
3499                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3500                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3501                 {
3502                     char tmpbuf[sizeof PL_tokenbuf];
3503                     STRLEN len;
3504                     for (t++; isSPACE(*t); t++) ;
3505                     if (isIDFIRST_lazy_if(t,UTF)) {
3506                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3507                         for (; isSPACE(*t); t++) ;
3508                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3509                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3510                                 "You need to quote \"%s\"", tmpbuf);
3511                     }
3512                 }
3513             }
3514         }
3515
3516         PL_expect = XOPERATOR;
3517         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3518             bool islop = (PL_last_lop == PL_oldoldbufptr);
3519             if (!islop || PL_last_lop_op == OP_GREPSTART)
3520                 PL_expect = XOPERATOR;
3521             else if (strchr("$@\"'`q", *s))
3522                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3523             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3524                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3525             else if (isIDFIRST_lazy_if(s,UTF)) {
3526                 char tmpbuf[sizeof PL_tokenbuf];
3527                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3528                 if ((tmp = keyword(tmpbuf, len))) {
3529                     /* binary operators exclude handle interpretations */
3530                     switch (tmp) {
3531                     case -KEY_x:
3532                     case -KEY_eq:
3533                     case -KEY_ne:
3534                     case -KEY_gt:
3535                     case -KEY_lt:
3536                     case -KEY_ge:
3537                     case -KEY_le:
3538                     case -KEY_cmp:
3539                         break;
3540                     default:
3541                         PL_expect = XTERM;      /* e.g. print $fh length() */
3542                         break;
3543                     }
3544                 }
3545                 else {
3546                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3547                     if (gv && GvCVu(gv))
3548                         PL_expect = XTERM;      /* e.g. print $fh subr() */
3549                 }
3550             }
3551             else if (isDIGIT(*s))
3552                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3553             else if (*s == '.' && isDIGIT(s[1]))
3554                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3555             else if (strchr("?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3556                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3557             else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3558                 PL_expect = XTERM;              /* e.g. print $fh /.../
3559                                                  XXX except DORDOR operator */
3560             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3561                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3562         }
3563         PL_pending_ident = '$';
3564         TOKEN('$');
3565
3566     case '@':
3567         if (PL_expect == XOPERATOR)
3568             no_op("Array", s);
3569         PL_tokenbuf[0] = '@';
3570         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3571         if (!PL_tokenbuf[1]) {
3572             if (s == PL_bufend)
3573                 yyerror("Final @ should be \\@ or @name");
3574             PREREF('@');
3575         }
3576         if (PL_lex_state == LEX_NORMAL)
3577             s = skipspace(s);
3578         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3579             if (*s == '{')
3580                 PL_tokenbuf[0] = '%';
3581
3582             /* Warn about @ where they meant $. */
3583             if (ckWARN(WARN_SYNTAX)) {
3584                 if (*s == '[' || *s == '{') {
3585                     char *t = s + 1;
3586                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3587                         t++;
3588                     if (*t == '}' || *t == ']') {
3589                         t++;
3590                         PL_bufptr = skipspace(PL_bufptr);
3591                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3592                             "Scalar value %.*s better written as $%.*s",
3593                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3594                     }
3595                 }
3596             }
3597         }
3598         PL_pending_ident = '@';
3599         TERM('@');
3600
3601      case '/':                  /* may be division, defined-or, or pattern */
3602         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3603             s += 2;
3604             AOPERATOR(DORDOR);
3605         }
3606      case '?':                  /* may either be conditional or pattern */
3607          if(PL_expect == XOPERATOR) {
3608              tmp = *s++;
3609              if(tmp == '?') {
3610                   OPERATOR('?');
3611              }
3612              else {
3613                  tmp = *s++;
3614                  if(tmp == '/') {
3615                      /* A // operator. */
3616                     AOPERATOR(DORDOR);
3617                  }
3618                  else {
3619                      s--;
3620                      Mop(OP_DIVIDE);
3621                  }
3622              }
3623          }
3624          else {
3625              /* Disable warning on "study /blah/" */
3626              if (PL_oldoldbufptr == PL_last_uni
3627               && (*PL_last_uni != 's' || s - PL_last_uni < 5
3628                   || memNE(PL_last_uni, "study", 5)
3629                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
3630               ))
3631                  check_uni();
3632              s = scan_pat(s,OP_MATCH);
3633              TERM(sublex_start());
3634          }
3635
3636     case '.':
3637         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3638 #ifdef PERL_STRICT_CR
3639             && s[1] == '\n'
3640 #else
3641             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3642 #endif
3643             && (s == PL_linestart || s[-1] == '\n') )
3644         {
3645             PL_lex_formbrack = 0;
3646             PL_expect = XSTATE;
3647             goto rightbracket;
3648         }
3649         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3650             tmp = *s++;
3651             if (*s == tmp) {
3652                 s++;
3653                 if (*s == tmp) {
3654                     s++;
3655                     yylval.ival = OPf_SPECIAL;
3656                 }
3657                 else
3658                     yylval.ival = 0;
3659                 OPERATOR(DOTDOT);
3660             }
3661             if (PL_expect != XOPERATOR)
3662                 check_uni();
3663             Aop(OP_CONCAT);
3664         }
3665         /* FALL THROUGH */
3666     case '0': case '1': case '2': case '3': case '4':
3667     case '5': case '6': case '7': case '8': case '9':
3668         s = scan_num(s, &yylval);
3669         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3670                     "### Saw number in '%s'\n", s);
3671         } );
3672         if (PL_expect == XOPERATOR)
3673             no_op("Number",s);
3674         TERM(THING);
3675
3676     case '\'':
3677         s = scan_str(s,FALSE,FALSE);
3678         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3679                     "### Saw string before '%s'\n", s);
3680         } );
3681         if (PL_expect == XOPERATOR) {
3682             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3683                 PL_expect = XTERM;
3684                 depcom();
3685                 return ',';     /* grandfather non-comma-format format */
3686             }
3687             else
3688                 no_op("String",s);
3689         }
3690         if (!s)
3691             missingterm((char*)0);
3692         yylval.ival = OP_CONST;
3693         TERM(sublex_start());
3694
3695     case '"':
3696         s = scan_str(s,FALSE,FALSE);
3697         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3698                     "### Saw string before '%s'\n", s);
3699         } );
3700         if (PL_expect == XOPERATOR) {
3701             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3702                 PL_expect = XTERM;
3703                 depcom();
3704                 return ',';     /* grandfather non-comma-format format */
3705             }
3706             else
3707                 no_op("String",s);
3708         }
3709         if (!s)
3710             missingterm((char*)0);
3711         yylval.ival = OP_CONST;
3712         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3713             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3714                 yylval.ival = OP_STRINGIFY;
3715                 break;
3716             }
3717         }
3718         TERM(sublex_start());
3719
3720     case '`':
3721         s = scan_str(s,FALSE,FALSE);
3722         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3723                     "### Saw backtick string before '%s'\n", s);
3724         } );
3725         if (PL_expect == XOPERATOR)
3726             no_op("Backticks",s);
3727         if (!s)
3728             missingterm((char*)0);
3729         yylval.ival = OP_BACKTICK;
3730         set_csh();
3731         TERM(sublex_start());
3732
3733     case '\\':
3734         s++;
3735         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3736             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3737                         *s, *s);
3738         if (PL_expect == XOPERATOR)
3739             no_op("Backslash",s);
3740         OPERATOR(REFGEN);
3741
3742     case 'v':
3743         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3744             char *start = s;
3745             start++;
3746             start++;
3747             while (isDIGIT(*start) || *start == '_')
3748                 start++;
3749             if (*start == '.' && isDIGIT(start[1])) {
3750                 s = scan_num(s, &yylval);
3751                 TERM(THING);
3752             }
3753             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3754             else if (!isALPHA(*start) && (PL_expect == XTERM
3755                         || PL_expect == XREF || PL_expect == XSTATE
3756                         || PL_expect == XTERMORDORDOR)) {
3757                 char c = *start;
3758                 GV *gv;
3759                 *start = '\0';
3760                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3761                 *start = c;
3762                 if (!gv) {
3763                     s = scan_num(s, &yylval);
3764                     TERM(THING);
3765                 }
3766             }
3767         }
3768         goto keylookup;
3769     case 'x':
3770         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3771             s++;
3772             Mop(OP_REPEAT);
3773         }
3774         goto keylookup;
3775
3776     case '_':
3777     case 'a': case 'A':
3778     case 'b': case 'B':
3779     case 'c': case 'C':
3780     case 'd': case 'D':
3781     case 'e': case 'E':
3782     case 'f': case 'F':
3783     case 'g': case 'G':
3784     case 'h': case 'H':
3785     case 'i': case 'I':
3786     case 'j': case 'J':
3787     case 'k': case 'K':
3788     case 'l': case 'L':
3789     case 'm': case 'M':
3790     case 'n': case 'N':
3791     case 'o': case 'O':
3792     case 'p': case 'P':
3793     case 'q': case 'Q':
3794     case 'r': case 'R':
3795     case 's': case 'S':
3796     case 't': case 'T':
3797     case 'u': case 'U':
3798               case 'V':
3799     case 'w': case 'W':
3800               case 'X':
3801     case 'y': case 'Y':
3802     case 'z': case 'Z':
3803
3804       keylookup: {
3805         gv = Nullgv;
3806         gvp = 0;
3807
3808         PL_bufptr = s;
3809         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3810
3811         /* Some keywords can be followed by any delimiter, including ':' */
3812         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3813                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3814                              (PL_tokenbuf[0] == 'q' &&
3815                               strchr("qwxr", PL_tokenbuf[1])))));
3816
3817         /* x::* is just a word, unless x is "CORE" */
3818         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3819             goto just_a_word;
3820
3821         d = s;
3822         while (d < PL_bufend && isSPACE(*d))
3823                 d++;    /* no comments skipped here, or s### is misparsed */
3824
3825         /* Is this a label? */
3826         if (!tmp && PL_expect == XSTATE
3827               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3828             s = d + 1;
3829             yylval.pval = savepv(PL_tokenbuf);
3830             CLINE;
3831             TOKEN(LABEL);
3832         }
3833
3834         /* Check for keywords */
3835         tmp = keyword(PL_tokenbuf, len);
3836
3837         /* Is this a word before a => operator? */
3838         if (*d == '=' && d[1] == '>') {
3839             CLINE;
3840             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3841             yylval.opval->op_private = OPpCONST_BARE;
3842             if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3843               SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3844             TERM(WORD);
3845         }
3846
3847         if (tmp < 0) {                  /* second-class keyword? */
3848             GV *ogv = Nullgv;   /* override (winner) */
3849             GV *hgv = Nullgv;   /* hidden (loser) */
3850             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3851                 CV *cv;
3852                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3853                     (cv = GvCVu(gv)))
3854                 {
3855                     if (GvIMPORTED_CV(gv))
3856                         ogv = gv;
3857                     else if (! CvMETHOD(cv))
3858                         hgv = gv;
3859                 }
3860                 if (!ogv &&
3861                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3862                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3863                     GvCVu(gv) && GvIMPORTED_CV(gv))
3864                 {
3865                     ogv = gv;
3866                 }
3867             }
3868             if (ogv) {
3869                 tmp = 0;                /* overridden by import or by GLOBAL */
3870             }
3871             else if (gv && !gvp
3872                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3873                      && GvCVu(gv)
3874                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3875             {
3876                 tmp = 0;                /* any sub overrides "weak" keyword */
3877             }
3878             else {                      /* no override */
3879                 tmp = -tmp;
3880                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
3881                     Perl_warner(aTHX_ packWARN(WARN_MISC),
3882                             "dump() better written as CORE::dump()");
3883                 }
3884                 gv = Nullgv;
3885                 gvp = 0;
3886                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3887                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3888                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3889                         "Ambiguous call resolved as CORE::%s(), %s",
3890                          GvENAME(hgv), "qualify as such or use &");
3891             }
3892         }
3893
3894       reserved_word:
3895         switch (tmp) {
3896
3897         default:                        /* not a keyword */
3898           just_a_word: {
3899                 SV *sv;
3900                 int pkgname = 0;
3901                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3902
3903                 /* Get the rest if it looks like a package qualifier */
3904
3905                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3906                     STRLEN morelen;
3907                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3908                                   TRUE, &morelen);
3909                     if (!morelen)
3910                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3911                                 *s == '\'' ? "'" : "::");
3912                     len += morelen;
3913                     pkgname = 1;
3914                 }
3915
3916                 if (PL_expect == XOPERATOR) {
3917                     if (PL_bufptr == PL_linestart) {
3918                         CopLINE_dec(PL_curcop);
3919                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3920                         CopLINE_inc(PL_curcop);
3921                     }
3922                     else
3923                         no_op("Bareword",s);
3924                 }
3925
3926                 /* Look for a subroutine with this name in current package,
3927                    unless name is "Foo::", in which case Foo is a bearword
3928                    (and a package name). */
3929
3930                 if (len > 2 &&
3931                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3932                 {
3933                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3934                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
3935                             "Bareword \"%s\" refers to nonexistent package",
3936                              PL_tokenbuf);
3937                     len -= 2;
3938                     PL_tokenbuf[len] = '\0';
3939                     gv = Nullgv;
3940                     gvp = 0;
3941                 }
3942                 else {
3943                     len = 0;
3944                     if (!gv)
3945                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3946                 }
3947
3948                 /* if we saw a global override before, get the right name */
3949
3950                 if (gvp) {
3951                     sv = newSVpvn("CORE::GLOBAL::",14);
3952                     sv_catpv(sv,PL_tokenbuf);
3953                 }
3954                 else
3955                     sv = newSVpv(PL_tokenbuf,0);
3956
3957                 /* Presume this is going to be a bareword of some sort. */
3958
3959                 CLINE;
3960                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3961                 yylval.opval->op_private = OPpCONST_BARE;
3962                 /* UTF-8 package name? */
3963                 if (UTF && !IN_BYTES &&
3964                     is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
3965                     SvUTF8_on(sv);
3966
3967                 /* And if "Foo::", then that's what it certainly is. */
3968
3969                 if (len)
3970                     goto safe_bareword;
3971
3972                 /* See if it's the indirect object for a list operator. */
3973
3974                 if (PL_oldoldbufptr &&
3975                     PL_oldoldbufptr < PL_bufptr &&
3976                     (PL_oldoldbufptr == PL_last_lop
3977                      || PL_oldoldbufptr == PL_last_uni) &&
3978                     /* NO SKIPSPACE BEFORE HERE! */
3979                     (PL_expect == XREF ||
3980                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3981                 {
3982                     bool immediate_paren = *s == '(';
3983
3984                     /* (Now we can afford to cross potential line boundary.) */
3985                     s = skipspace(s);
3986
3987                     /* Two barewords in a row may indicate method call. */
3988
3989                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3990                         return tmp;
3991
3992                     /* If not a declared subroutine, it's an indirect object. */
3993                     /* (But it's an indir obj regardless for sort.) */
3994
3995                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
3996                          ((!gv || !GvCVu(gv)) &&
3997                         (PL_last_lop_op != OP_MAPSTART &&
3998                          PL_last_lop_op != OP_GREPSTART))))
3999                     {
4000                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4001                         goto bareword;
4002                     }
4003                 }
4004
4005                 PL_expect = XOPERATOR;
4006                 s = skipspace(s);
4007
4008                 /* Is this a word before a => operator? */
4009                 if (*s == '=' && s[1] == '>' && !pkgname) {
4010                     CLINE;
4011                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4012                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4013                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4014                     TERM(WORD);
4015                 }
4016
4017                 /* If followed by a paren, it's certainly a subroutine. */
4018                 if (*s == '(') {
4019                     CLINE;
4020                     if (gv && GvCVu(gv)) {
4021                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4022                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4023                             s = d + 1;
4024                             goto its_constant;
4025                         }
4026                     }
4027                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4028                     PL_expect = XOPERATOR;
4029                     force_next(WORD);
4030                     yylval.ival = 0;
4031                     TOKEN('&');
4032                 }
4033
4034                 /* If followed by var or block, call it a method (unless sub) */
4035
4036                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4037                     PL_last_lop = PL_oldbufptr;
4038                     PL_last_lop_op = OP_METHOD;
4039                     PREBLOCK(METHOD);
4040                 }
4041
4042                 /* If followed by a bareword, see if it looks like indir obj. */
4043
4044                 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
4045                     return tmp;
4046
4047                 /* Not a method, so call it a subroutine (if defined) */
4048
4049                 if (gv && GvCVu(gv)) {
4050                     CV* cv;
4051                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4052                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4053                                 "Ambiguous use of -%s resolved as -&%s()",
4054                                 PL_tokenbuf, PL_tokenbuf);
4055                     /* Check for a constant sub */
4056                     cv = GvCV(gv);
4057                     if ((sv = cv_const_sv(cv))) {
4058                   its_constant:
4059                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4060                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4061                         yylval.opval->op_private = 0;
4062                         TOKEN(WORD);
4063                     }
4064
4065                     /* Resolve to GV now. */
4066                     op_free(yylval.opval);
4067                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4068                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4069                     PL_last_lop = PL_oldbufptr;
4070                     PL_last_lop_op = OP_ENTERSUB;
4071                     /* Is there a prototype? */
4072                     if (SvPOK(cv)) {
4073                         STRLEN len;
4074                         char *proto = SvPV((SV*)cv, len);
4075                         if (!len)
4076                             TERM(FUNC0SUB);
4077                         if (strEQ(proto, "$"))
4078                             OPERATOR(UNIOPSUB);
4079                         if (*proto == '&' && *s == '{') {
4080                             sv_setpv(PL_subname, PL_curstash ? 
4081                                         "__ANON__" : "__ANON__::__ANON__");
4082                             PREBLOCK(LSTOPSUB);
4083                         }
4084                     }
4085                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4086                     PL_expect = XTERM;
4087                     force_next(WORD);
4088                     TOKEN(NOAMP);
4089                 }
4090
4091                 /* Call it a bare word */
4092
4093                 if (PL_hints & HINT_STRICT_SUBS)
4094                     yylval.opval->op_private |= OPpCONST_STRICT;
4095                 else {
4096                 bareword:
4097                     if (ckWARN(WARN_RESERVED)) {
4098                         if (lastchar != '-') {
4099                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4100                             if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4101                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4102                                        PL_tokenbuf);
4103                         }
4104                     }
4105                 }
4106
4107             safe_bareword:
4108                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4109                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4110                         "Operator or semicolon missing before %c%s",
4111                         lastchar, PL_tokenbuf);
4112                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4113                         "Ambiguous use of %c resolved as operator %c",
4114                         lastchar, lastchar);
4115                 }
4116                 TOKEN(WORD);
4117             }
4118
4119         case KEY___FILE__:
4120             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4121                                         newSVpv(CopFILE(PL_curcop),0));
4122             TERM(THING);
4123
4124         case KEY___LINE__:
4125             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4126                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4127             TERM(THING);
4128
4129         case KEY___PACKAGE__:
4130             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4131                                         (PL_curstash
4132                                          ? newSVsv(PL_curstname)
4133                                          : &PL_sv_undef));
4134             TERM(THING);
4135
4136         case KEY___DATA__:
4137         case KEY___END__: {
4138             GV *gv;
4139
4140             /*SUPPRESS 560*/
4141             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4142                 char *pname = "main";
4143                 if (PL_tokenbuf[2] == 'D')
4144                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4145                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4146                 GvMULTI_on(gv);
4147                 if (!GvIO(gv))
4148                     GvIOp(gv) = newIO();
4149                 IoIFP(GvIOp(gv)) = PL_rsfp;
4150 #if defined(HAS_FCNTL) && defined(F_SETFD)
4151                 {
4152                     int fd = PerlIO_fileno(PL_rsfp);
4153                     fcntl(fd,F_SETFD,fd >= 3);
4154                 }
4155 #endif
4156                 /* Mark this internal pseudo-handle as clean */
4157                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4158                 if (PL_preprocess)
4159                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4160                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4161                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4162                 else
4163                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4164 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4165                 /* if the script was opened in binmode, we need to revert
4166                  * it to text mode for compatibility; but only iff it has CRs
4167                  * XXX this is a questionable hack at best. */
4168                 if (PL_bufend-PL_bufptr > 2
4169                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4170                 {
4171                     Off_t loc = 0;
4172                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4173                         loc = PerlIO_tell(PL_rsfp);
4174                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
4175                     }
4176 #ifdef NETWARE
4177                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4178 #else
4179                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4180 #endif  /* NETWARE */
4181 #ifdef PERLIO_IS_STDIO /* really? */
4182 #  if defined(__BORLANDC__)
4183                         /* XXX see note in do_binmode() */
4184                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4185 #  endif
4186 #endif
4187                         if (loc > 0)
4188                             PerlIO_seek(PL_rsfp, loc, 0);
4189                     }
4190                 }
4191 #endif
4192 #ifdef PERLIO_LAYERS
4193                 if (UTF && !IN_BYTES)
4194                     PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4195 #endif
4196                 PL_rsfp = Nullfp;
4197             }
4198             goto fake_eof;
4199         }
4200
4201         case KEY_AUTOLOAD:
4202         case KEY_DESTROY:
4203         case KEY_BEGIN:
4204         case KEY_CHECK:
4205         case KEY_INIT:
4206         case KEY_END:
4207             if (PL_expect == XSTATE) {
4208                 s = PL_bufptr;
4209                 goto really_sub;
4210             }
4211             goto just_a_word;
4212
4213         case KEY_CORE:
4214             if (*s == ':' && s[1] == ':') {
4215                 s += 2;
4216                 d = s;
4217                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4218                 if (!(tmp = keyword(PL_tokenbuf, len)))
4219                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4220                 if (tmp < 0)
4221                     tmp = -tmp;
4222                 goto reserved_word;
4223             }
4224             goto just_a_word;
4225
4226         case KEY_abs:
4227             UNI(OP_ABS);
4228
4229         case KEY_alarm:
4230             UNI(OP_ALARM);
4231
4232         case KEY_accept:
4233             LOP(OP_ACCEPT,XTERM);
4234
4235         case KEY_and:
4236             OPERATOR(ANDOP);
4237
4238         case KEY_atan2:
4239             LOP(OP_ATAN2,XTERM);
4240
4241         case KEY_bind:
4242             LOP(OP_BIND,XTERM);
4243
4244         case KEY_binmode:
4245             LOP(OP_BINMODE,XTERM);
4246
4247         case KEY_bless:
4248             LOP(OP_BLESS,XTERM);
4249
4250         case KEY_chop:
4251             UNI(OP_CHOP);
4252
4253         case KEY_continue:
4254             PREBLOCK(CONTINUE);
4255
4256         case KEY_chdir:
4257             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
4258             UNI(OP_CHDIR);
4259
4260         case KEY_close:
4261             UNI(OP_CLOSE);
4262
4263         case KEY_closedir:
4264             UNI(OP_CLOSEDIR);
4265
4266         case KEY_cmp:
4267             Eop(OP_SCMP);
4268
4269         case KEY_caller:
4270             UNI(OP_CALLER);
4271
4272         case KEY_crypt:
4273 #ifdef FCRYPT
4274             if (!PL_cryptseen) {
4275                 PL_cryptseen = TRUE;
4276                 init_des();
4277             }
4278 #endif
4279             LOP(OP_CRYPT,XTERM);
4280
4281         case KEY_chmod:
4282             LOP(OP_CHMOD,XTERM);
4283
4284         case KEY_chown:
4285             LOP(OP_CHOWN,XTERM);
4286
4287         case KEY_connect:
4288             LOP(OP_CONNECT,XTERM);
4289
4290         case KEY_chr:
4291             UNI(OP_CHR);
4292
4293         case KEY_cos:
4294             UNI(OP_COS);
4295
4296         case KEY_chroot:
4297             UNI(OP_CHROOT);
4298
4299         case KEY_do:
4300             s = skipspace(s);
4301             if (*s == '{')
4302                 PRETERMBLOCK(DO);
4303             if (*s != '\'')
4304                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4305             OPERATOR(DO);
4306
4307         case KEY_die:
4308             PL_hints |= HINT_BLOCK_SCOPE;
4309             LOP(OP_DIE,XTERM);
4310
4311         case KEY_defined:
4312             UNI(OP_DEFINED);
4313
4314         case KEY_delete:
4315             UNI(OP_DELETE);
4316
4317         case KEY_dbmopen:
4318             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4319             LOP(OP_DBMOPEN,XTERM);
4320
4321         case KEY_dbmclose:
4322             UNI(OP_DBMCLOSE);
4323
4324         case KEY_dump:
4325             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4326             LOOPX(OP_DUMP);
4327
4328         case KEY_else:
4329             PREBLOCK(ELSE);