This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [ID 20010920.007] q and qq does not work after do
[perl5.git] / toke.c
1 /*    toke.c
2  *
3  *    Copyright (c) 1991-2001, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  */
9
10 /*
11  *   "It all comes from here, the stench and the peril."  --Frodo
12  */
13
14 /*
15  * This file is the lexer for Perl.  It's closely linked to the
16  * parser, perly.y.
17  *
18  * The main routine is yylex(), which returns the next token.
19  */
20
21 #include "EXTERN.h"
22 #define PERL_IN_TOKE_C
23 #include "perl.h"
24
25 #define yychar  PL_yychar
26 #define yylval  PL_yylval
27
28 static char ident_too_long[] = "Identifier too long";
29
30 static void restore_rsfp(pTHX_ void *f);
31 #ifndef PERL_NO_UTF16_FILTER
32 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
33 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
34 #endif
35
36 #define XFAKEBRACK 128
37 #define XENUMMASK 127
38
39 #ifdef USE_UTF8_SCRIPTS
40 #   define UTF (!IN_BYTES)
41 #else
42 #   ifdef EBCDIC /* For now 'use utf8' does not affect tokenizer on EBCDIC */
43 #       define UTF (PL_linestr && DO_UTF8(PL_linestr))
44 #   else
45 #       define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
46 #   endif
47 #endif
48
49 /* In variables named $^X, these are the legal values for X.
50  * 1999-02-27 mjd-perl-patch@plover.com */
51 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
52
53 /* On MacOS, respect nonbreaking spaces */
54 #ifdef MACOS_TRADITIONAL
55 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
56 #else
57 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
58 #endif
59
60 /* LEX_* are values for PL_lex_state, the state of the lexer.
61  * They are arranged oddly so that the guard on the switch statement
62  * can get by with a single comparison (if the compiler is smart enough).
63  */
64
65 /* #define LEX_NOTPARSING               11 is done in perl.h. */
66
67 #define LEX_NORMAL              10
68 #define LEX_INTERPNORMAL         9
69 #define LEX_INTERPCASEMOD        8
70 #define LEX_INTERPPUSH           7
71 #define LEX_INTERPSTART          6
72 #define LEX_INTERPEND            5
73 #define LEX_INTERPENDMAYBE       4
74 #define LEX_INTERPCONCAT         3
75 #define LEX_INTERPCONST          2
76 #define LEX_FORMLINE             1
77 #define LEX_KNOWNEXT             0
78
79 #ifdef ff_next
80 #undef ff_next
81 #endif
82
83 #ifdef USE_PURE_BISON
84 #  ifndef YYMAXLEVEL
85 #    define YYMAXLEVEL 100
86 #  endif
87 YYSTYPE* yylval_pointer[YYMAXLEVEL];
88 int* yychar_pointer[YYMAXLEVEL];
89 int yyactlevel = -1;
90 #  undef yylval
91 #  undef yychar
92 #  define yylval (*yylval_pointer[yyactlevel])
93 #  define yychar (*yychar_pointer[yyactlevel])
94 #  define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
95 #  undef yylex
96 #  define yylex()      Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
97 #endif
98
99 #include "keywords.h"
100
101 /* CLINE is a macro that ensures PL_copline has a sane value */
102
103 #ifdef CLINE
104 #undef CLINE
105 #endif
106 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
107
108 /*
109  * Convenience functions to return different tokens and prime the
110  * lexer for the next token.  They all take an argument.
111  *
112  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
113  * OPERATOR     : generic operator
114  * AOPERATOR    : assignment operator
115  * PREBLOCK     : beginning the block after an if, while, foreach, ...
116  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
117  * PREREF       : *EXPR where EXPR is not a simple identifier
118  * TERM         : expression term
119  * LOOPX        : loop exiting command (goto, last, dump, etc)
120  * FTST         : file test operator
121  * FUN0         : zero-argument function
122  * FUN1         : not used, except for not, which isn't a UNIOP
123  * BOop         : bitwise or or xor
124  * BAop         : bitwise and
125  * SHop         : shift operator
126  * PWop         : power operator
127  * PMop         : pattern-matching operator
128  * Aop          : addition-level operator
129  * Mop          : multiplication-level operator
130  * Eop          : equality-testing operator
131  * Rop          : relational operator <= != gt
132  *
133  * Also see LOP and lop() below.
134  */
135
136 /* Note that REPORT() and REPORT2() will be expressions that supply
137  * their own trailing comma, not suitable for statements as such. */
138 #ifdef DEBUGGING /* Serve -DT. */
139 #   define REPORT(x,retval) tokereport(x,s,(int)retval),
140 #   define REPORT2(x,retval) tokereport(x,s, yylval.ival),
141 #else
142 #   define REPORT(x,retval)
143 #   define REPORT2(x,retval)
144 #endif
145
146 #define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
147 #define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
148 #define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
149 #define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
150 #define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
151 #define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
152 #define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
153 #define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
154 #define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
155 #define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
156 #define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
157 #define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
158 #define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
159 #define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
160 #define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
161 #define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
162 #define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
163 #define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
164 #define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
165 #define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
166
167 /* This bit of chicanery makes a unary function followed by
168  * a parenthesis into a function with one argument, highest precedence.
169  */
170 #define UNI(f) return(yylval.ival = f, \
171         REPORT("uni",f) \
172         PL_expect = XTERM, \
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
178 #define UNIBRACK(f) return(yylval.ival = f, \
179         REPORT("uni",f) \
180         PL_bufptr = s, \
181         PL_last_uni = PL_oldbufptr, \
182         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
183
184 /* grandfather return to old style */
185 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
186
187 #ifdef DEBUGGING
188
189 STATIC void
190 S_tokereport(pTHX_ char *thing, char* s, I32 rv)
191 {
192     DEBUG_T({
193         SV* report = newSVpv(thing, 0);
194         Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
195                 (IV)rv);
196
197         if (s - PL_bufptr > 0)
198             sv_catpvn(report, PL_bufptr, s - PL_bufptr);
199         else {
200             if (PL_oldbufptr && *PL_oldbufptr)
201                 sv_catpv(report, PL_tokenbuf);
202         }
203         PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
204     });
205 }
206
207 #endif
208
209 /*
210  * S_ao
211  *
212  * This subroutine detects &&= and ||= and turns an ANDAND or OROR
213  * into an OP_ANDASSIGN or OP_ORASSIGN
214  */
215
216 STATIC int
217 S_ao(pTHX_ int toketype)
218 {
219     if (*PL_bufptr == '=') {
220         PL_bufptr++;
221         if (toketype == ANDAND)
222             yylval.ival = OP_ANDASSIGN;
223         else if (toketype == OROR)
224             yylval.ival = OP_ORASSIGN;
225         toketype = ASSIGNOP;
226     }
227     return toketype;
228 }
229
230 /*
231  * S_no_op
232  * When Perl expects an operator and finds something else, no_op
233  * prints the warning.  It always prints "<something> found where
234  * operator expected.  It prints "Missing semicolon on previous line?"
235  * if the surprise occurs at the start of the line.  "do you need to
236  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
237  * where the compiler doesn't know if foo is a method call or a function.
238  * It prints "Missing operator before end of line" if there's nothing
239  * after the missing operator, or "... before <...>" if there is something
240  * after the missing operator.
241  */
242
243 STATIC void
244 S_no_op(pTHX_ char *what, char *s)
245 {
246     char *oldbp = PL_bufptr;
247     bool is_first = (PL_oldbufptr == PL_linestart);
248
249     if (!s)
250         s = oldbp;
251     else
252         PL_bufptr = s;
253     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
254     if (is_first)
255         Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
256     else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
257         char *t;
258         for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
259         if (t < PL_bufptr && isSPACE(*t))
260             Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
261                 t - PL_oldoldbufptr, PL_oldoldbufptr);
262     }
263     else {
264         assert(s >= oldbp);
265         Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
266     }
267     PL_bufptr = oldbp;
268 }
269
270 /*
271  * S_missingterm
272  * Complain about missing quote/regexp/heredoc terminator.
273  * If it's called with (char *)NULL then it cauterizes the line buffer.
274  * If we're in a delimited string and the delimiter is a control
275  * character, it's reformatted into a two-char sequence like ^C.
276  * This is fatal.
277  */
278
279 STATIC void
280 S_missingterm(pTHX_ char *s)
281 {
282     char tmpbuf[3];
283     char q;
284     if (s) {
285         char *nl = strrchr(s,'\n');
286         if (nl)
287             *nl = '\0';
288     }
289     else if (
290 #ifdef EBCDIC
291         iscntrl(PL_multi_close)
292 #else
293         PL_multi_close < 32 || PL_multi_close == 127
294 #endif
295         ) {
296         *tmpbuf = '^';
297         tmpbuf[1] = toCTRL(PL_multi_close);
298         s = "\\n";
299         tmpbuf[2] = '\0';
300         s = tmpbuf;
301     }
302     else {
303         *tmpbuf = PL_multi_close;
304         tmpbuf[1] = '\0';
305         s = tmpbuf;
306     }
307     q = strchr(s,'"') ? '\'' : '"';
308     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
309 }
310
311 /*
312  * Perl_deprecate
313  */
314
315 void
316 Perl_deprecate(pTHX_ char *s)
317 {
318     if (ckWARN(WARN_DEPRECATED))
319         Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
320 }
321
322 /*
323  * depcom
324  * Deprecate a comma-less variable list.
325  */
326
327 STATIC void
328 S_depcom(pTHX)
329 {
330     deprecate("comma-less variable list");
331 }
332
333 /*
334  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
335  * utf16-to-utf8-reversed.
336  */
337
338 #ifdef PERL_CR_FILTER
339 static void
340 strip_return(SV *sv)
341 {
342     register char *s = SvPVX(sv);
343     register char *e = s + SvCUR(sv);
344     /* outer loop optimized to do nothing if there are no CR-LFs */
345     while (s < e) {
346         if (*s++ == '\r' && *s == '\n') {
347             /* hit a CR-LF, need to copy the rest */
348             register char *d = s - 1;
349             *d++ = *s++;
350             while (s < e) {
351                 if (*s == '\r' && s[1] == '\n')
352                     s++;
353                 *d++ = *s++;
354             }
355             SvCUR(sv) -= s - d;
356             return;
357         }
358     }
359 }
360
361 STATIC I32
362 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
363 {
364     I32 count = FILTER_READ(idx+1, sv, maxlen);
365     if (count > 0 && !maxlen)
366         strip_return(sv);
367     return count;
368 }
369 #endif
370
371 /*
372  * Perl_lex_start
373  * Initialize variables.  Uses the Perl save_stack to save its state (for
374  * recursive calls to the parser).
375  */
376
377 void
378 Perl_lex_start(pTHX_ SV *line)
379 {
380     char *s;
381     STRLEN len;
382
383     SAVEI32(PL_lex_dojoin);
384     SAVEI32(PL_lex_brackets);
385     SAVEI32(PL_lex_casemods);
386     SAVEI32(PL_lex_starts);
387     SAVEI32(PL_lex_state);
388     SAVEVPTR(PL_lex_inpat);
389     SAVEI32(PL_lex_inwhat);
390     if (PL_lex_state == LEX_KNOWNEXT) {
391         I32 toke = PL_nexttoke;
392         while (--toke >= 0) {
393             SAVEI32(PL_nexttype[toke]);
394             SAVEVPTR(PL_nextval[toke]);
395         }
396         SAVEI32(PL_nexttoke);
397     }
398     SAVECOPLINE(PL_curcop);
399     SAVEPPTR(PL_bufptr);
400     SAVEPPTR(PL_bufend);
401     SAVEPPTR(PL_oldbufptr);
402     SAVEPPTR(PL_oldoldbufptr);
403     SAVEPPTR(PL_last_lop);
404     SAVEPPTR(PL_last_uni);
405     SAVEPPTR(PL_linestart);
406     SAVESPTR(PL_linestr);
407     SAVEPPTR(PL_lex_brackstack);
408     SAVEPPTR(PL_lex_casestack);
409     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
410     SAVESPTR(PL_lex_stuff);
411     SAVEI32(PL_lex_defer);
412     SAVEI32(PL_sublex_info.sub_inwhat);
413     SAVESPTR(PL_lex_repl);
414     SAVEINT(PL_expect);
415     SAVEINT(PL_lex_expect);
416
417     PL_lex_state = LEX_NORMAL;
418     PL_lex_defer = 0;
419     PL_expect = XSTATE;
420     PL_lex_brackets = 0;
421     New(899, PL_lex_brackstack, 120, char);
422     New(899, PL_lex_casestack, 12, char);
423     SAVEFREEPV(PL_lex_brackstack);
424     SAVEFREEPV(PL_lex_casestack);
425     PL_lex_casemods = 0;
426     *PL_lex_casestack = '\0';
427     PL_lex_dojoin = 0;
428     PL_lex_starts = 0;
429     PL_lex_stuff = Nullsv;
430     PL_lex_repl = Nullsv;
431     PL_lex_inpat = 0;
432     PL_nexttoke = 0;
433     PL_lex_inwhat = 0;
434     PL_sublex_info.sub_inwhat = 0;
435     PL_linestr = line;
436     if (SvREADONLY(PL_linestr))
437         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
438     s = SvPV(PL_linestr, len);
439     if (len && s[len-1] != ';') {
440         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
441             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
442         sv_catpvn(PL_linestr, "\n;", 2);
443     }
444     SvTEMP_off(PL_linestr);
445     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
446     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
447     PL_last_lop = PL_last_uni = Nullch;
448     PL_rsfp = 0;
449 }
450
451 /*
452  * Perl_lex_end
453  * Finalizer for lexing operations.  Must be called when the parser is
454  * done with the lexer.
455  */
456
457 void
458 Perl_lex_end(pTHX)
459 {
460     PL_doextract = FALSE;
461 }
462
463 /*
464  * S_incline
465  * This subroutine has nothing to do with tilting, whether at windmills
466  * or pinball tables.  Its name is short for "increment line".  It
467  * increments the current line number in CopLINE(PL_curcop) and checks
468  * to see whether the line starts with a comment of the form
469  *    # line 500 "foo.pm"
470  * If so, it sets the current line number and file to the values in the comment.
471  */
472
473 STATIC void
474 S_incline(pTHX_ char *s)
475 {
476     char *t;
477     char *n;
478     char *e;
479     char ch;
480
481     CopLINE_inc(PL_curcop);
482     if (*s++ != '#')
483         return;
484     while (SPACE_OR_TAB(*s)) s++;
485     if (strnEQ(s, "line", 4))
486         s += 4;
487     else
488         return;
489     if (SPACE_OR_TAB(*s))
490         s++;
491     else
492         return;
493     while (SPACE_OR_TAB(*s)) s++;
494     if (!isDIGIT(*s))
495         return;
496     n = s;
497     while (isDIGIT(*s))
498         s++;
499     while (SPACE_OR_TAB(*s))
500         s++;
501     if (*s == '"' && (t = strchr(s+1, '"'))) {
502         s++;
503         e = t + 1;
504     }
505     else {
506         for (t = s; !isSPACE(*t); t++) ;
507         e = t;
508     }
509     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
510         e++;
511     if (*e != '\n' && *e != '\0')
512         return;         /* false alarm */
513
514     ch = *t;
515     *t = '\0';
516     if (t - s > 0) {
517 #ifdef USE_ITHREADS
518         Safefree(CopFILE(PL_curcop));
519 #else
520         SvREFCNT_dec(CopFILEGV(PL_curcop));
521 #endif
522         CopFILE_set(PL_curcop, s);
523     }
524     *t = ch;
525     CopLINE_set(PL_curcop, atoi(n)-1);
526 }
527
528 /*
529  * S_skipspace
530  * Called to gobble the appropriate amount and type of whitespace.
531  * Skips comments as well.
532  */
533
534 STATIC char *
535 S_skipspace(pTHX_ register char *s)
536 {
537     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
538         while (s < PL_bufend && SPACE_OR_TAB(*s))
539             s++;
540         return s;
541     }
542     for (;;) {
543         STRLEN prevlen;
544         SSize_t oldprevlen, oldoldprevlen;
545         SSize_t oldloplen = 0, oldunilen = 0;
546         while (s < PL_bufend && isSPACE(*s)) {
547             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
548                 incline(s);
549         }
550
551         /* comment */
552         if (s < PL_bufend && *s == '#') {
553             while (s < PL_bufend && *s != '\n')
554                 s++;
555             if (s < PL_bufend) {
556                 s++;
557                 if (PL_in_eval && !PL_rsfp) {
558                     incline(s);
559                     continue;
560                 }
561             }
562         }
563
564         /* only continue to recharge the buffer if we're at the end
565          * of the buffer, we're not reading from a source filter, and
566          * we're in normal lexing mode
567          */
568         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
569                 PL_lex_state == LEX_FORMLINE)
570             return s;
571
572         /* try to recharge the buffer */
573         if ((s = filter_gets(PL_linestr, PL_rsfp,
574                              (prevlen = SvCUR(PL_linestr)))) == Nullch)
575         {
576             /* end of file.  Add on the -p or -n magic */
577             if (PL_minus_n || PL_minus_p) {
578                 sv_setpv(PL_linestr,PL_minus_p ?
579                          ";}continue{print or die qq(-p destination: $!\\n)" :
580                          "");
581                 sv_catpv(PL_linestr,";}");
582                 PL_minus_n = PL_minus_p = 0;
583             }
584             else
585                 sv_setpv(PL_linestr,";");
586
587             /* reset variables for next time we lex */
588             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
589                 = SvPVX(PL_linestr);
590             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
591             PL_last_lop = PL_last_uni = Nullch;
592
593             /* Close the filehandle.  Could be from -P preprocessor,
594              * STDIN, or a regular file.  If we were reading code from
595              * STDIN (because the commandline held no -e or filename)
596              * then we don't close it, we reset it so the code can
597              * read from STDIN too.
598              */
599
600             if (PL_preprocess && !PL_in_eval)
601                 (void)PerlProc_pclose(PL_rsfp);
602             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
603                 PerlIO_clearerr(PL_rsfp);
604             else
605                 (void)PerlIO_close(PL_rsfp);
606             PL_rsfp = Nullfp;
607             return s;
608         }
609
610         /* not at end of file, so we only read another line */
611         /* make corresponding updates to old pointers, for yyerror() */
612         oldprevlen = PL_oldbufptr - PL_bufend;
613         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
614         if (PL_last_uni)
615             oldunilen = PL_last_uni - PL_bufend;
616         if (PL_last_lop)
617             oldloplen = PL_last_lop - PL_bufend;
618         PL_linestart = PL_bufptr = s + prevlen;
619         PL_bufend = s + SvCUR(PL_linestr);
620         s = PL_bufptr;
621         PL_oldbufptr = s + oldprevlen;
622         PL_oldoldbufptr = s + oldoldprevlen;
623         if (PL_last_uni)
624             PL_last_uni = s + oldunilen;
625         if (PL_last_lop)
626             PL_last_lop = s + oldloplen;
627         incline(s);
628
629         /* debugger active and we're not compiling the debugger code,
630          * so store the line into the debugger's array of lines
631          */
632         if (PERLDB_LINE && PL_curstash != PL_debstash) {
633             SV *sv = NEWSV(85,0);
634
635             sv_upgrade(sv, SVt_PVMG);
636             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
637             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
638         }
639     }
640 }
641
642 /*
643  * S_check_uni
644  * Check the unary operators to ensure there's no ambiguity in how they're
645  * used.  An ambiguous piece of code would be:
646  *     rand + 5
647  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
648  * the +5 is its argument.
649  */
650
651 STATIC void
652 S_check_uni(pTHX)
653 {
654     char *s;
655     char *t;
656
657     if (PL_oldoldbufptr != PL_last_uni)
658         return;
659     while (isSPACE(*PL_last_uni))
660         PL_last_uni++;
661     for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
662     if ((t = strchr(s, '(')) && t < PL_bufptr)
663         return;
664     if (ckWARN_d(WARN_AMBIGUOUS)){
665         char ch = *s;
666         *s = '\0';
667         Perl_warner(aTHX_ WARN_AMBIGUOUS,
668                    "Warning: Use of \"%s\" without parens is ambiguous",
669                    PL_last_uni);
670         *s = ch;
671     }
672 }
673
674 /* workaround to replace the UNI() macro with a function.  Only the
675  * hints/uts.sh file mentions this.  Other comments elsewhere in the
676  * source indicate Microport Unix might need it too.
677  */
678
679 #ifdef CRIPPLED_CC
680
681 #undef UNI
682 #define UNI(f) return uni(f,s)
683
684 STATIC int
685 S_uni(pTHX_ I32 f, char *s)
686 {
687     yylval.ival = f;
688     PL_expect = XTERM;
689     PL_bufptr = s;
690     PL_last_uni = PL_oldbufptr;
691     PL_last_lop_op = f;
692     if (*s == '(')
693         return FUNC1;
694     s = skipspace(s);
695     if (*s == '(')
696         return FUNC1;
697     else
698         return UNIOP;
699 }
700
701 #endif /* CRIPPLED_CC */
702
703 /*
704  * LOP : macro to build a list operator.  Its behaviour has been replaced
705  * with a subroutine, S_lop() for which LOP is just another name.
706  */
707
708 #define LOP(f,x) return lop(f,x,s)
709
710 /*
711  * S_lop
712  * Build a list operator (or something that might be one).  The rules:
713  *  - if we have a next token, then it's a list operator [why?]
714  *  - if the next thing is an opening paren, then it's a function
715  *  - else it's a list operator
716  */
717
718 STATIC I32
719 S_lop(pTHX_ I32 f, int x, char *s)
720 {
721     yylval.ival = f;
722     CLINE;
723     REPORT("lop", f)
724     PL_expect = x;
725     PL_bufptr = s;
726     PL_last_lop = PL_oldbufptr;
727     PL_last_lop_op = f;
728     if (PL_nexttoke)
729         return LSTOP;
730     if (*s == '(')
731         return FUNC;
732     s = skipspace(s);
733     if (*s == '(')
734         return FUNC;
735     else
736         return LSTOP;
737 }
738
739 /*
740  * S_force_next
741  * When the lexer realizes it knows the next token (for instance,
742  * it is reordering tokens for the parser) then it can call S_force_next
743  * to know what token to return the next time the lexer is called.  Caller
744  * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
745  * handles the token correctly.
746  */
747
748 STATIC void
749 S_force_next(pTHX_ I32 type)
750 {
751     PL_nexttype[PL_nexttoke] = type;
752     PL_nexttoke++;
753     if (PL_lex_state != LEX_KNOWNEXT) {
754         PL_lex_defer = PL_lex_state;
755         PL_lex_expect = PL_expect;
756         PL_lex_state = LEX_KNOWNEXT;
757     }
758 }
759
760 /*
761  * S_force_word
762  * When the lexer knows the next thing is a word (for instance, it has
763  * just seen -> and it knows that the next char is a word char, then
764  * it calls S_force_word to stick the next word into the PL_next lookahead.
765  *
766  * Arguments:
767  *   char *start : buffer position (must be within PL_linestr)
768  *   int token   : PL_next will be this type of bare word (e.g., METHOD,WORD)
769  *   int check_keyword : if true, Perl checks to make sure the word isn't
770  *       a keyword (do this if the word is a label, e.g. goto FOO)
771  *   int allow_pack : if true, : characters will also be allowed (require,
772  *       use, etc. do this)
773  *   int allow_initial_tick : used by the "sub" lexer only.
774  */
775
776 STATIC char *
777 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
778 {
779     register char *s;
780     STRLEN len;
781
782     start = skipspace(start);
783     s = start;
784     if (isIDFIRST_lazy_if(s,UTF) ||
785         (allow_pack && *s == ':') ||
786         (allow_initial_tick && *s == '\'') )
787     {
788         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
789         if (check_keyword && keyword(PL_tokenbuf, len))
790             return start;
791         if (token == METHOD) {
792             s = skipspace(s);
793             if (*s == '(')
794                 PL_expect = XTERM;
795             else {
796                 PL_expect = XOPERATOR;
797             }
798         }
799         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
800         PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
801         force_next(token);
802     }
803     return s;
804 }
805
806 /*
807  * S_force_ident
808  * Called when the lexer wants $foo *foo &foo etc, but the program
809  * text only contains the "foo" portion.  The first argument is a pointer
810  * to the "foo", and the second argument is the type symbol to prefix.
811  * Forces the next token to be a "WORD".
812  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
813  */
814
815 STATIC void
816 S_force_ident(pTHX_ register char *s, int kind)
817 {
818     if (s && *s) {
819         OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
820         PL_nextval[PL_nexttoke].opval = o;
821         force_next(WORD);
822         if (kind) {
823             o->op_private = OPpCONST_ENTERED;
824             /* XXX see note in pp_entereval() for why we forgo typo
825                warnings if the symbol must be introduced in an eval.
826                GSAR 96-10-12 */
827             gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
828                 kind == '$' ? SVt_PV :
829                 kind == '@' ? SVt_PVAV :
830                 kind == '%' ? SVt_PVHV :
831                               SVt_PVGV
832                 );
833         }
834     }
835 }
836
837 NV
838 Perl_str_to_version(pTHX_ SV *sv)
839 {
840     NV retval = 0.0;
841     NV nshift = 1.0;
842     STRLEN len;
843     char *start = SvPVx(sv,len);
844     bool utf = SvUTF8(sv) ? TRUE : FALSE;
845     char *end = start + len;
846     while (start < end) {
847         STRLEN skip;
848         UV n;
849         if (utf)
850             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
851         else {
852             n = *(U8*)start;
853             skip = 1;
854         }
855         retval += ((NV)n)/nshift;
856         start += skip;
857         nshift *= 1000;
858     }
859     return retval;
860 }
861
862 /*
863  * S_force_version
864  * Forces the next token to be a version number.
865  * If the next token appears to be an invalid version number, (e.g. "v2b"),
866  * and if "guessing" is TRUE, then no new token is created (and the caller
867  * must use an alternative parsing method).
868  */
869
870 STATIC char *
871 S_force_version(pTHX_ char *s, int guessing)
872 {
873     OP *version = Nullop;
874     char *d;
875
876     s = skipspace(s);
877
878     d = s;
879     if (*d == 'v')
880         d++;
881     if (isDIGIT(*d)) {
882         while (isDIGIT(*d) || *d == '_' || *d == '.')
883             d++;
884         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
885             SV *ver;
886             s = scan_num(s, &yylval);
887             version = yylval.opval;
888             ver = cSVOPx(version)->op_sv;
889             if (SvPOK(ver) && !SvNIOK(ver)) {
890                 (void)SvUPGRADE(ver, SVt_PVNV);
891                 SvNVX(ver) = str_to_version(ver);
892                 SvNOK_on(ver);          /* hint that it is a version */
893             }
894         }
895         else if (guessing)
896             return s;
897     }
898
899     /* NOTE: The parser sees the package name and the VERSION swapped */
900     PL_nextval[PL_nexttoke].opval = version;
901     force_next(WORD);
902
903     return s;
904 }
905
906 /*
907  * S_tokeq
908  * Tokenize a quoted string passed in as an SV.  It finds the next
909  * chunk, up to end of string or a backslash.  It may make a new
910  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
911  * turns \\ into \.
912  */
913
914 STATIC SV *
915 S_tokeq(pTHX_ SV *sv)
916 {
917     register char *s;
918     register char *send;
919     register char *d;
920     STRLEN len = 0;
921     SV *pv = sv;
922
923     if (!SvLEN(sv))
924         goto finish;
925
926     s = SvPV_force(sv, len);
927     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
928         goto finish;
929     send = s + len;
930     while (s < send && *s != '\\')
931         s++;
932     if (s == send)
933         goto finish;
934     d = s;
935     if ( PL_hints & HINT_NEW_STRING ) {
936         pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
937         if (SvUTF8(sv))
938             SvUTF8_on(pv);
939     }
940     while (s < send) {
941         if (*s == '\\') {
942             if (s + 1 < send && (s[1] == '\\'))
943                 s++;            /* all that, just for this */
944         }
945         *d++ = *s++;
946     }
947     *d = '\0';
948     SvCUR_set(sv, d - SvPVX(sv));
949   finish:
950     if ( PL_hints & HINT_NEW_STRING )
951        return new_constant(NULL, 0, "q", sv, pv, "q");
952     return sv;
953 }
954
955 /*
956  * Now come three functions related to double-quote context,
957  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
958  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
959  * interact with PL_lex_state, and create fake ( ... ) argument lists
960  * to handle functions and concatenation.
961  * They assume that whoever calls them will be setting up a fake
962  * join call, because each subthing puts a ',' after it.  This lets
963  *   "lower \luPpEr"
964  * become
965  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
966  *
967  * (I'm not sure whether the spurious commas at the end of lcfirst's
968  * arguments and join's arguments are created or not).
969  */
970
971 /*
972  * S_sublex_start
973  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
974  *
975  * Pattern matching will set PL_lex_op to the pattern-matching op to
976  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
977  *
978  * OP_CONST and OP_READLINE are easy--just make the new op and return.
979  *
980  * Everything else becomes a FUNC.
981  *
982  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
983  * had an OP_CONST or OP_READLINE).  This just sets us up for a
984  * call to S_sublex_push().
985  */
986
987 STATIC I32
988 S_sublex_start(pTHX)
989 {
990     register I32 op_type = yylval.ival;
991
992     if (op_type == OP_NULL) {
993         yylval.opval = PL_lex_op;
994         PL_lex_op = Nullop;
995         return THING;
996     }
997     if (op_type == OP_CONST || op_type == OP_READLINE) {
998         SV *sv = tokeq(PL_lex_stuff);
999
1000         if (SvTYPE(sv) == SVt_PVIV) {
1001             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1002             STRLEN len;
1003             char *p;
1004             SV *nsv;
1005
1006             p = SvPV(sv, len);
1007             nsv = newSVpvn(p, len);
1008             if (SvUTF8(sv))
1009                 SvUTF8_on(nsv);
1010             SvREFCNT_dec(sv);
1011             sv = nsv;
1012         }
1013         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1014         PL_lex_stuff = Nullsv;
1015         return THING;
1016     }
1017
1018     PL_sublex_info.super_state = PL_lex_state;
1019     PL_sublex_info.sub_inwhat = op_type;
1020     PL_sublex_info.sub_op = PL_lex_op;
1021     PL_lex_state = LEX_INTERPPUSH;
1022
1023     PL_expect = XTERM;
1024     if (PL_lex_op) {
1025         yylval.opval = PL_lex_op;
1026         PL_lex_op = Nullop;
1027         return PMFUNC;
1028     }
1029     else
1030         return FUNC;
1031 }
1032
1033 /*
1034  * S_sublex_push
1035  * Create a new scope to save the lexing state.  The scope will be
1036  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1037  * to the uc, lc, etc. found before.
1038  * Sets PL_lex_state to LEX_INTERPCONCAT.
1039  */
1040
1041 STATIC I32
1042 S_sublex_push(pTHX)
1043 {
1044     ENTER;
1045
1046     PL_lex_state = PL_sublex_info.super_state;
1047     SAVEI32(PL_lex_dojoin);
1048     SAVEI32(PL_lex_brackets);
1049     SAVEI32(PL_lex_casemods);
1050     SAVEI32(PL_lex_starts);
1051     SAVEI32(PL_lex_state);
1052     SAVEVPTR(PL_lex_inpat);
1053     SAVEI32(PL_lex_inwhat);
1054     SAVECOPLINE(PL_curcop);
1055     SAVEPPTR(PL_bufptr);
1056     SAVEPPTR(PL_bufend);
1057     SAVEPPTR(PL_oldbufptr);
1058     SAVEPPTR(PL_oldoldbufptr);
1059     SAVEPPTR(PL_last_lop);
1060     SAVEPPTR(PL_last_uni);
1061     SAVEPPTR(PL_linestart);
1062     SAVESPTR(PL_linestr);
1063     SAVEPPTR(PL_lex_brackstack);
1064     SAVEPPTR(PL_lex_casestack);
1065
1066     PL_linestr = PL_lex_stuff;
1067     PL_lex_stuff = Nullsv;
1068
1069     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1070         = SvPVX(PL_linestr);
1071     PL_bufend += SvCUR(PL_linestr);
1072     PL_last_lop = PL_last_uni = Nullch;
1073     SAVEFREESV(PL_linestr);
1074
1075     PL_lex_dojoin = FALSE;
1076     PL_lex_brackets = 0;
1077     New(899, PL_lex_brackstack, 120, char);
1078     New(899, PL_lex_casestack, 12, char);
1079     SAVEFREEPV(PL_lex_brackstack);
1080     SAVEFREEPV(PL_lex_casestack);
1081     PL_lex_casemods = 0;
1082     *PL_lex_casestack = '\0';
1083     PL_lex_starts = 0;
1084     PL_lex_state = LEX_INTERPCONCAT;
1085     CopLINE_set(PL_curcop, PL_multi_start);
1086
1087     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1088     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1089         PL_lex_inpat = PL_sublex_info.sub_op;
1090     else
1091         PL_lex_inpat = Nullop;
1092
1093     return '(';
1094 }
1095
1096 /*
1097  * S_sublex_done
1098  * Restores lexer state after a S_sublex_push.
1099  */
1100
1101 STATIC I32
1102 S_sublex_done(pTHX)
1103 {
1104     if (!PL_lex_starts++) {
1105         SV *sv = newSVpvn("",0);
1106         if (SvUTF8(PL_linestr))
1107             SvUTF8_on(sv);
1108         PL_expect = XOPERATOR;
1109         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1110         return THING;
1111     }
1112
1113     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1114         PL_lex_state = LEX_INTERPCASEMOD;
1115         return yylex();
1116     }
1117
1118     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1119     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1120         PL_linestr = PL_lex_repl;
1121         PL_lex_inpat = 0;
1122         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1123         PL_bufend += SvCUR(PL_linestr);
1124         PL_last_lop = PL_last_uni = Nullch;
1125         SAVEFREESV(PL_linestr);
1126         PL_lex_dojoin = FALSE;
1127         PL_lex_brackets = 0;
1128         PL_lex_casemods = 0;
1129         *PL_lex_casestack = '\0';
1130         PL_lex_starts = 0;
1131         if (SvEVALED(PL_lex_repl)) {
1132             PL_lex_state = LEX_INTERPNORMAL;
1133             PL_lex_starts++;
1134             /*  we don't clear PL_lex_repl here, so that we can check later
1135                 whether this is an evalled subst; that means we rely on the
1136                 logic to ensure sublex_done() is called again only via the
1137                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1138         }
1139         else {
1140             PL_lex_state = LEX_INTERPCONCAT;
1141             PL_lex_repl = Nullsv;
1142         }
1143         return ',';
1144     }
1145     else {
1146         LEAVE;
1147         PL_bufend = SvPVX(PL_linestr);
1148         PL_bufend += SvCUR(PL_linestr);
1149         PL_expect = XOPERATOR;
1150         PL_sublex_info.sub_inwhat = 0;
1151         return ')';
1152     }
1153 }
1154
1155 /*
1156   scan_const
1157
1158   Extracts a pattern, double-quoted string, or transliteration.  This
1159   is terrifying code.
1160
1161   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1162   processing a pattern (PL_lex_inpat is true), a transliteration
1163   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1164
1165   Returns a pointer to the character scanned up to. Iff this is
1166   advanced from the start pointer supplied (ie if anything was
1167   successfully parsed), will leave an OP for the substring scanned
1168   in yylval. Caller must intuit reason for not parsing further
1169   by looking at the next characters herself.
1170
1171   In patterns:
1172     backslashes:
1173       double-quoted style: \r and \n
1174       regexp special ones: \D \s
1175       constants: \x3
1176       backrefs: \1 (deprecated in substitution replacements)
1177       case and quoting: \U \Q \E
1178     stops on @ and $, but not for $ as tail anchor
1179
1180   In transliterations:
1181     characters are VERY literal, except for - not at the start or end
1182     of the string, which indicates a range.  scan_const expands the
1183     range to the full set of intermediate characters.
1184
1185   In double-quoted strings:
1186     backslashes:
1187       double-quoted style: \r and \n
1188       constants: \x3
1189       backrefs: \1 (deprecated)
1190       case and quoting: \U \Q \E
1191     stops on @ and $
1192
1193   scan_const does *not* construct ops to handle interpolated strings.
1194   It stops processing as soon as it finds an embedded $ or @ variable
1195   and leaves it to the caller to work out what's going on.
1196
1197   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
1198
1199   $ in pattern could be $foo or could be tail anchor.  Assumption:
1200   it's a tail anchor if $ is the last thing in the string, or if it's
1201   followed by one of ")| \n\t"
1202
1203   \1 (backreferences) are turned into $1
1204
1205   The structure of the code is
1206       while (there's a character to process) {
1207           handle transliteration ranges
1208           skip regexp comments
1209           skip # initiated comments in //x patterns
1210           check for embedded @foo
1211           check for embedded scalars
1212           if (backslash) {
1213               leave intact backslashes from leave (below)
1214               deprecate \1 in strings and sub replacements
1215               handle string-changing backslashes \l \U \Q \E, etc.
1216               switch (what was escaped) {
1217                   handle - in a transliteration (becomes a literal -)
1218                   handle \132 octal characters
1219                   handle 0x15 hex characters
1220                   handle \cV (control V)
1221                   handle printf backslashes (\f, \r, \n, etc)
1222               } (end switch)
1223           } (end if backslash)
1224     } (end while character to read)
1225                 
1226 */
1227
1228 STATIC char *
1229 S_scan_const(pTHX_ char *start)
1230 {
1231     register char *send = PL_bufend;            /* end of the constant */
1232     SV *sv = NEWSV(93, send - start);           /* sv for the constant */
1233     register char *s = start;                   /* start of the constant */
1234     register char *d = SvPVX(sv);               /* destination for copies */
1235     bool dorange = FALSE;                       /* are we in a translit range? */
1236     bool didrange = FALSE;                      /* did we just finish a range? */
1237     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1238     I32  this_utf8 = UTF;                       /* The source string is assumed to be UTF8 */
1239     UV uv;
1240
1241     const char *leaveit =       /* set of acceptably-backslashed characters */
1242         PL_lex_inpat
1243             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1244             : "";
1245
1246     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1247         /* If we are doing a trans and we know we want UTF8 set expectation */
1248         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1249         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1250     }
1251
1252
1253     while (s < send || dorange) {
1254         /* get transliterations out of the way (they're most literal) */
1255         if (PL_lex_inwhat == OP_TRANS) {
1256             /* expand a range A-Z to the full set of characters.  AIE! */
1257             if (dorange) {
1258                 I32 i;                          /* current expanded character */
1259                 I32 min;                        /* first character in range */
1260                 I32 max;                        /* last character in range */
1261
1262                 if (has_utf8) {
1263                     char *c = (char*)utf8_hop((U8*)d, -1);
1264                     char *e = d++;
1265                     while (e-- > c)
1266                         *(e + 1) = *e;
1267                     *c = (char)UTF_TO_NATIVE(0xff);
1268                     /* mark the range as done, and continue */
1269                     dorange = FALSE;
1270                     didrange = TRUE;
1271                     continue;
1272                 }
1273
1274                 i = d - SvPVX(sv);              /* remember current offset */
1275                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1276                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1277                 d -= 2;                         /* eat the first char and the - */
1278
1279                 min = (U8)*d;                   /* first char in range */
1280                 max = (U8)d[1];                 /* last char in range  */
1281
1282                 if (min > max) {
1283                     Perl_croak(aTHX_
1284                                "Invalid [] range \"%c-%c\" in transliteration operator",
1285                                (char)min, (char)max);
1286                 }
1287
1288 #ifdef EBCDIC
1289                 if ((isLOWER(min) && isLOWER(max)) ||
1290                     (isUPPER(min) && isUPPER(max))) {
1291                     if (isLOWER(min)) {
1292                         for (i = min; i <= max; i++)
1293                             if (isLOWER(i))
1294                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1295                     } else {
1296                         for (i = min; i <= max; i++)
1297                             if (isUPPER(i))
1298                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1299                     }
1300                 }
1301                 else
1302 #endif
1303                     for (i = min; i <= max; i++)
1304                         *d++ = i;
1305
1306                 /* mark the range as done, and continue */
1307                 dorange = FALSE;
1308                 didrange = TRUE;
1309                 continue;
1310             }
1311
1312             /* range begins (ignore - as first or last char) */
1313             else if (*s == '-' && s+1 < send  && s != start) {
1314                 if (didrange) {
1315                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1316                 }
1317                 if (has_utf8) {
1318                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
1319                     s++;
1320                     continue;
1321                 }
1322                 dorange = TRUE;
1323                 s++;
1324             }
1325             else {
1326                 didrange = FALSE;
1327             }
1328         }
1329
1330         /* if we get here, we're not doing a transliteration */
1331
1332         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1333            except for the last char, which will be done separately. */
1334         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1335             if (s[2] == '#') {
1336                 while (s < send && *s != ')')
1337                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1338             }
1339             else if (s[2] == '{' /* This should match regcomp.c */
1340                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1341             {
1342                 I32 count = 1;
1343                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1344                 char c;
1345
1346                 while (count && (c = *regparse)) {
1347                     if (c == '\\' && regparse[1])
1348                         regparse++;
1349                     else if (c == '{')
1350                         count++;
1351                     else if (c == '}')
1352                         count--;
1353                     regparse++;
1354                 }
1355                 if (*regparse != ')') {
1356                     regparse--;         /* Leave one char for continuation. */
1357                     yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1358                 }
1359                 while (s < regparse)
1360                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1361             }
1362         }
1363
1364         /* likewise skip #-initiated comments in //x patterns */
1365         else if (*s == '#' && PL_lex_inpat &&
1366           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1367             while (s+1 < send && *s != '\n')
1368                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1369         }
1370
1371         /* check for embedded arrays
1372            (@foo, @:foo, @'foo, @{foo}, @$foo, @+, @-)
1373            */
1374         else if (*s == '@' && s[1]
1375                  && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1376             break;
1377
1378         /* check for embedded scalars.  only stop if we're sure it's a
1379            variable.
1380         */
1381         else if (*s == '$') {
1382             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1383                 break;
1384             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1385                 break;          /* in regexp, $ might be tail anchor */
1386         }
1387
1388         /* End of else if chain - OP_TRANS rejoin rest */
1389
1390         /* backslashes */
1391         if (*s == '\\' && s+1 < send) {
1392             s++;
1393
1394             /* some backslashes we leave behind */
1395             if (*leaveit && *s && strchr(leaveit, *s)) {
1396                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1397                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1398                 continue;
1399             }
1400
1401             /* deprecate \1 in strings and substitution replacements */
1402             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1403                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1404             {
1405                 if (ckWARN(WARN_SYNTAX))
1406                     Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1407                 *--s = '$';
1408                 break;
1409             }
1410
1411             /* string-change backslash escapes */
1412             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1413                 --s;
1414                 break;
1415             }
1416
1417             /* if we get here, it's either a quoted -, or a digit */
1418             switch (*s) {
1419
1420             /* quoted - in transliterations */
1421             case '-':
1422                 if (PL_lex_inwhat == OP_TRANS) {
1423                     *d++ = *s++;
1424                     continue;
1425                 }
1426                 /* FALL THROUGH */
1427             default:
1428                 {
1429                     if (ckWARN(WARN_MISC) && isALNUM(*s))
1430                         Perl_warner(aTHX_ WARN_MISC,
1431                                "Unrecognized escape \\%c passed through",
1432                                *s);
1433                     /* default action is to copy the quoted character */
1434                     goto default_action;
1435                 }
1436
1437             /* \132 indicates an octal constant */
1438             case '0': case '1': case '2': case '3':
1439             case '4': case '5': case '6': case '7':
1440                 {
1441                     I32 flags = 0;
1442                     STRLEN len = 3;
1443                     uv = grok_oct(s, &len, &flags, NULL);
1444                     s += len;
1445                 }
1446                 goto NUM_ESCAPE_INSERT;
1447
1448             /* \x24 indicates a hex constant */
1449             case 'x':
1450                 ++s;
1451                 if (*s == '{') {
1452                     char* e = strchr(s, '}');
1453                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1454                       PERL_SCAN_DISALLOW_PREFIX;
1455                     STRLEN len;
1456
1457                     ++s;
1458                     if (!e) {
1459                         yyerror("Missing right brace on \\x{}");
1460                         continue;
1461                     }
1462                     len = e - s;
1463                     uv = grok_hex(s, &len, &flags, NULL);
1464                     s = e + 1;
1465                 }
1466                 else {
1467                     {
1468                         STRLEN len = 2;
1469                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1470                         uv = grok_hex(s, &len, &flags, NULL);
1471                         s += len;
1472                     }
1473                 }
1474
1475               NUM_ESCAPE_INSERT:
1476                 /* Insert oct or hex escaped character.
1477                  * There will always enough room in sv since such
1478                  * escapes will be longer than any UTF-8 sequence
1479                  * they can end up as. */
1480                 
1481                 /* We need to map to chars to ASCII before doing the tests
1482                    to cover EBCDIC
1483                 */
1484                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1485                     if (!has_utf8 && uv > 255) {
1486                         /* Might need to recode whatever we have
1487                          * accumulated so far if it contains any
1488                          * hibit chars.
1489                          *
1490                          * (Can't we keep track of that and avoid
1491                          *  this rescan? --jhi)
1492                          */
1493                         int hicount = 0;
1494                         U8 *c;
1495                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1496                             if (!NATIVE_IS_INVARIANT(*c)) {
1497                                 hicount++;
1498                             }
1499                         }
1500                         if (hicount) {
1501                             STRLEN offset = d - SvPVX(sv);
1502                             U8 *src, *dst;
1503                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1504                             src = (U8 *)d - 1;
1505                             dst = src+hicount;
1506                             d  += hicount;
1507                             while (src >= (U8 *)SvPVX(sv)) {
1508                                 if (!NATIVE_IS_INVARIANT(*src)) {
1509                                     U8 ch = NATIVE_TO_ASCII(*src);
1510                                     *dst-- = UTF8_EIGHT_BIT_LO(ch);
1511                                     *dst-- = UTF8_EIGHT_BIT_HI(ch);
1512                                 }
1513                                 else {
1514                                     *dst-- = *src;
1515                                 }
1516                                 src--;
1517                             }
1518                         }
1519                     }
1520
1521                     if (has_utf8 || uv > 255) {
1522                         d = (char*)uvchr_to_utf8((U8*)d, uv);
1523                         has_utf8 = TRUE;
1524                         if (PL_lex_inwhat == OP_TRANS &&
1525                             PL_sublex_info.sub_op) {
1526                             PL_sublex_info.sub_op->op_private |=
1527                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
1528                                              : OPpTRANS_TO_UTF);
1529                         }
1530                     }
1531                     else {
1532                         *d++ = (char)uv;
1533                     }
1534                 }
1535                 else {
1536                     *d++ = (char) uv;
1537                 }
1538                 continue;
1539
1540             /* \N{latin small letter a} is a named character */
1541             case 'N':
1542                 ++s;
1543                 if (*s == '{') {
1544                     char* e = strchr(s, '}');
1545                     SV *res;
1546                     STRLEN len;
1547                     char *str;
1548
1549                     if (!e) {
1550                         yyerror("Missing right brace on \\N{}");
1551                         e = s - 1;
1552                         goto cont_scan;
1553                     }
1554                     res = newSVpvn(s + 1, e - s - 1);
1555                     res = new_constant( Nullch, 0, "charnames",
1556                                         res, Nullsv, "\\N{...}" );
1557                     if (has_utf8)
1558                         sv_utf8_upgrade(res);
1559                     str = SvPV(res,len);
1560                     if (!has_utf8 && SvUTF8(res)) {
1561                         char *ostart = SvPVX(sv);
1562                         SvCUR_set(sv, d - ostart);
1563                         SvPOK_on(sv);
1564                         *d = '\0';
1565                         sv_utf8_upgrade(sv);
1566                         /* this just broke our allocation above... */
1567                         SvGROW(sv, send - start);
1568                         d = SvPVX(sv) + SvCUR(sv);
1569                         has_utf8 = TRUE;
1570                     }
1571                     if (len > e - s + 4) {
1572                         char *odest = SvPVX(sv);
1573
1574                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1575                         d = SvPVX(sv) + (d - odest);
1576                     }
1577                     Copy(str, d, len, char);
1578                     d += len;
1579                     SvREFCNT_dec(res);
1580                   cont_scan:
1581                     s = e + 1;
1582                 }
1583                 else
1584                     yyerror("Missing braces on \\N{}");
1585                 continue;
1586
1587             /* \c is a control character */
1588             case 'c':
1589                 s++;
1590                 {
1591                     U8 c = *s++;
1592 #ifdef EBCDIC
1593                     if (isLOWER(c))
1594                         c = toUPPER(c);
1595 #endif
1596                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1597                 }
1598                 continue;
1599
1600             /* printf-style backslashes, formfeeds, newlines, etc */
1601             case 'b':
1602                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1603                 break;
1604             case 'n':
1605                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1606                 break;
1607             case 'r':
1608                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1609                 break;
1610             case 'f':
1611                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1612                 break;
1613             case 't':
1614                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1615                 break;
1616             case 'e':
1617                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1618                 break;
1619             case 'a':
1620                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1621                 break;
1622             } /* end switch */
1623
1624             s++;
1625             continue;
1626         } /* end if (backslash) */
1627
1628     default_action:
1629         /* If we started with encoded form, or already know we want it
1630            and then encode the next character */
1631         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1632             STRLEN len  = 1;
1633             UV uv       = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1634             STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1635             s += len;
1636             if (need > len) {
1637                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1638                 STRLEN off = d - SvPVX(sv);
1639                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1640             }
1641             d = (char*)uvchr_to_utf8((U8*)d, uv);
1642             has_utf8 = TRUE;
1643         }
1644         else {
1645             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1646         }
1647     } /* while loop to process each character */
1648
1649     /* terminate the string and set up the sv */
1650     *d = '\0';
1651     SvCUR_set(sv, d - SvPVX(sv));
1652     if (SvCUR(sv) >= SvLEN(sv))
1653       Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1654
1655     SvPOK_on(sv);
1656     if (has_utf8) {
1657         SvUTF8_on(sv);
1658         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1659                 PL_sublex_info.sub_op->op_private |=
1660                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1661         }
1662     }
1663
1664     /* shrink the sv if we allocated more than we used */
1665     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1666         SvLEN_set(sv, SvCUR(sv) + 1);
1667         Renew(SvPVX(sv), SvLEN(sv), char);
1668     }
1669
1670     /* return the substring (via yylval) only if we parsed anything */
1671     if (s > PL_bufptr) {
1672         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1673             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1674                               sv, Nullsv,
1675                               ( PL_lex_inwhat == OP_TRANS
1676                                 ? "tr"
1677                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1678                                     ? "s"
1679                                     : "qq")));
1680         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1681     } else
1682         SvREFCNT_dec(sv);
1683     return s;
1684 }
1685
1686 /* S_intuit_more
1687  * Returns TRUE if there's more to the expression (e.g., a subscript),
1688  * FALSE otherwise.
1689  *
1690  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1691  *
1692  * ->[ and ->{ return TRUE
1693  * { and [ outside a pattern are always subscripts, so return TRUE
1694  * if we're outside a pattern and it's not { or [, then return FALSE
1695  * if we're in a pattern and the first char is a {
1696  *   {4,5} (any digits around the comma) returns FALSE
1697  * if we're in a pattern and the first char is a [
1698  *   [] returns FALSE
1699  *   [SOMETHING] has a funky algorithm to decide whether it's a
1700  *      character class or not.  It has to deal with things like
1701  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1702  * anything else returns TRUE
1703  */
1704
1705 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1706
1707 STATIC int
1708 S_intuit_more(pTHX_ register char *s)
1709 {
1710     if (PL_lex_brackets)
1711         return TRUE;
1712     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1713         return TRUE;
1714     if (*s != '{' && *s != '[')
1715         return FALSE;
1716     if (!PL_lex_inpat)
1717         return TRUE;
1718
1719     /* In a pattern, so maybe we have {n,m}. */
1720     if (*s == '{') {
1721         s++;
1722         if (!isDIGIT(*s))
1723             return TRUE;
1724         while (isDIGIT(*s))
1725             s++;
1726         if (*s == ',')
1727             s++;
1728         while (isDIGIT(*s))
1729             s++;
1730         if (*s == '}')
1731             return FALSE;
1732         return TRUE;
1733         
1734     }
1735
1736     /* On the other hand, maybe we have a character class */
1737
1738     s++;
1739     if (*s == ']' || *s == '^')
1740         return FALSE;
1741     else {
1742         /* this is terrifying, and it works */
1743         int weight = 2;         /* let's weigh the evidence */
1744         char seen[256];
1745         unsigned char un_char = 255, last_un_char;
1746         char *send = strchr(s,']');
1747         char tmpbuf[sizeof PL_tokenbuf * 4];
1748
1749         if (!send)              /* has to be an expression */
1750             return TRUE;
1751
1752         Zero(seen,256,char);
1753         if (*s == '$')
1754             weight -= 3;
1755         else if (isDIGIT(*s)) {
1756             if (s[1] != ']') {
1757                 if (isDIGIT(s[1]) && s[2] == ']')
1758                     weight -= 10;
1759             }
1760             else
1761                 weight -= 100;
1762         }
1763         for (; s < send; s++) {
1764             last_un_char = un_char;
1765             un_char = (unsigned char)*s;
1766             switch (*s) {
1767             case '@':
1768             case '&':
1769             case '$':
1770                 weight -= seen[un_char] * 10;
1771                 if (isALNUM_lazy_if(s+1,UTF)) {
1772                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1773                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1774                         weight -= 100;
1775                     else
1776                         weight -= 10;
1777                 }
1778                 else if (*s == '$' && s[1] &&
1779                   strchr("[#!%*<>()-=",s[1])) {
1780                     if (/*{*/ strchr("])} =",s[2]))
1781                         weight -= 10;
1782                     else
1783                         weight -= 1;
1784                 }
1785                 break;
1786             case '\\':
1787                 un_char = 254;
1788                 if (s[1]) {
1789                     if (strchr("wds]",s[1]))
1790                         weight += 100;
1791                     else if (seen['\''] || seen['"'])
1792                         weight += 1;
1793                     else if (strchr("rnftbxcav",s[1]))
1794                         weight += 40;
1795                     else if (isDIGIT(s[1])) {
1796                         weight += 40;
1797                         while (s[1] && isDIGIT(s[1]))
1798                             s++;
1799                     }
1800                 }
1801                 else
1802                     weight += 100;
1803                 break;
1804             case '-':
1805                 if (s[1] == '\\')
1806                     weight += 50;
1807                 if (strchr("aA01! ",last_un_char))
1808                     weight += 30;
1809                 if (strchr("zZ79~",s[1]))
1810                     weight += 30;
1811                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1812                     weight -= 5;        /* cope with negative subscript */
1813                 break;
1814             default:
1815                 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1816                         isALPHA(*s) && s[1] && isALPHA(s[1])) {
1817                     char *d = tmpbuf;
1818                     while (isALPHA(*s))
1819                         *d++ = *s++;
1820                     *d = '\0';
1821                     if (keyword(tmpbuf, d - tmpbuf))
1822                         weight -= 150;
1823                 }
1824                 if (un_char == last_un_char + 1)
1825                     weight += 5;
1826                 weight -= seen[un_char];
1827                 break;
1828             }
1829             seen[un_char]++;
1830         }
1831         if (weight >= 0)        /* probably a character class */
1832             return FALSE;
1833     }
1834
1835     return TRUE;
1836 }
1837
1838 /*
1839  * S_intuit_method
1840  *
1841  * Does all the checking to disambiguate
1842  *   foo bar
1843  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
1844  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1845  *
1846  * First argument is the stuff after the first token, e.g. "bar".
1847  *
1848  * Not a method if bar is a filehandle.
1849  * Not a method if foo is a subroutine prototyped to take a filehandle.
1850  * Not a method if it's really "Foo $bar"
1851  * Method if it's "foo $bar"
1852  * Not a method if it's really "print foo $bar"
1853  * Method if it's really "foo package::" (interpreted as package->foo)
1854  * Not a method if bar is known to be a subroutne ("sub bar; foo bar")
1855  * Not a method if bar is a filehandle or package, but is quoted with
1856  *   =>
1857  */
1858
1859 STATIC int
1860 S_intuit_method(pTHX_ char *start, GV *gv)
1861 {
1862     char *s = start + (*start == '$');
1863     char tmpbuf[sizeof PL_tokenbuf];
1864     STRLEN len;
1865     GV* indirgv;
1866
1867     if (gv) {
1868         CV *cv;
1869         if (GvIO(gv))
1870             return 0;
1871         if ((cv = GvCVu(gv))) {
1872             char *proto = SvPVX(cv);
1873             if (proto) {
1874                 if (*proto == ';')
1875                     proto++;
1876                 if (*proto == '*')
1877                     return 0;
1878             }
1879         } else
1880             gv = 0;
1881     }
1882     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1883     /* start is the beginning of the possible filehandle/object,
1884      * and s is the end of it
1885      * tmpbuf is a copy of it
1886      */
1887
1888     if (*start == '$') {
1889         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1890             return 0;
1891         s = skipspace(s);
1892         PL_bufptr = start;
1893         PL_expect = XREF;
1894         return *s == '(' ? FUNCMETH : METHOD;
1895     }
1896     if (!keyword(tmpbuf, len)) {
1897         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1898             len -= 2;
1899             tmpbuf[len] = '\0';
1900             goto bare_package;
1901         }
1902         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1903         if (indirgv && GvCVu(indirgv))
1904             return 0;
1905         /* filehandle or package name makes it a method */
1906         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1907             s = skipspace(s);
1908             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1909                 return 0;       /* no assumptions -- "=>" quotes bearword */
1910       bare_package:
1911             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1912                                                    newSVpvn(tmpbuf,len));
1913             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1914             PL_expect = XTERM;
1915             force_next(WORD);
1916             PL_bufptr = s;
1917             return *s == '(' ? FUNCMETH : METHOD;
1918         }
1919     }
1920     return 0;
1921 }
1922
1923 /*
1924  * S_incl_perldb
1925  * Return a string of Perl code to load the debugger.  If PERL5DB
1926  * is set, it will return the contents of that, otherwise a
1927  * compile-time require of perl5db.pl.
1928  */
1929
1930 STATIC char*
1931 S_incl_perldb(pTHX)
1932 {
1933     if (PL_perldb) {
1934         char *pdb = PerlEnv_getenv("PERL5DB");
1935
1936         if (pdb)
1937             return pdb;
1938         SETERRNO(0,SS$_NORMAL);
1939         return "BEGIN { require 'perl5db.pl' }";
1940     }
1941     return "";
1942 }
1943
1944
1945 /* Encoded script support. filter_add() effectively inserts a
1946  * 'pre-processing' function into the current source input stream.
1947  * Note that the filter function only applies to the current source file
1948  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1949  *
1950  * The datasv parameter (which may be NULL) can be used to pass
1951  * private data to this instance of the filter. The filter function
1952  * can recover the SV using the FILTER_DATA macro and use it to
1953  * store private buffers and state information.
1954  *
1955  * The supplied datasv parameter is upgraded to a PVIO type
1956  * and the IoDIRP/IoANY field is used to store the function pointer,
1957  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1958  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1959  * private use must be set using malloc'd pointers.
1960  */
1961
1962 SV *
1963 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1964 {
1965     if (!funcp)
1966         return Nullsv;
1967
1968     if (!PL_rsfp_filters)
1969         PL_rsfp_filters = newAV();
1970     if (!datasv)
1971         datasv = NEWSV(255,0);
1972     if (!SvUPGRADE(datasv, SVt_PVIO))
1973         Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1974     IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1975     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1976     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1977                           funcp, SvPV_nolen(datasv)));
1978     av_unshift(PL_rsfp_filters, 1);
1979     av_store(PL_rsfp_filters, 0, datasv) ;
1980     return(datasv);
1981 }
1982
1983
1984 /* Delete most recently added instance of this filter function. */
1985 void
1986 Perl_filter_del(pTHX_ filter_t funcp)
1987 {
1988     SV *datasv;
1989     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp));
1990     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1991         return;
1992     /* if filter is on top of stack (usual case) just pop it off */
1993     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
1994     if (IoANY(datasv) == (void *)funcp) {
1995         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
1996         IoANY(datasv) = (void *)NULL;
1997         sv_free(av_pop(PL_rsfp_filters));
1998
1999         return;
2000     }
2001     /* we need to search for the correct entry and clear it     */
2002     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2003 }
2004
2005
2006 /* Invoke the n'th filter function for the current rsfp.         */
2007 I32
2008 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2009
2010
2011                         /* 0 = read one text line */
2012 {
2013     filter_t funcp;
2014     SV *datasv = NULL;
2015
2016     if (!PL_rsfp_filters)
2017         return -1;
2018     if (idx > AvFILLp(PL_rsfp_filters)){       /* Any more filters?     */
2019         /* Provide a default input filter to make life easy.    */
2020         /* Note that we append to the line. This is handy.      */
2021         DEBUG_P(PerlIO_printf(Perl_debug_log,
2022                               "filter_read %d: from rsfp\n", idx));
2023         if (maxlen) {
2024             /* Want a block */
2025             int len ;
2026             int old_len = SvCUR(buf_sv) ;
2027
2028             /* ensure buf_sv is large enough */
2029             SvGROW(buf_sv, old_len + maxlen) ;
2030             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2031                 if (PerlIO_error(PL_rsfp))
2032                     return -1;          /* error */
2033                 else
2034                     return 0 ;          /* end of file */
2035             }
2036             SvCUR_set(buf_sv, old_len + len) ;
2037         } else {
2038             /* Want a line */
2039             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2040                 if (PerlIO_error(PL_rsfp))
2041                     return -1;          /* error */
2042                 else
2043                     return 0 ;          /* end of file */
2044             }
2045         }
2046         return SvCUR(buf_sv);
2047     }
2048     /* Skip this filter slot if filter has been deleted */
2049     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2050         DEBUG_P(PerlIO_printf(Perl_debug_log,
2051                               "filter_read %d: skipped (filter deleted)\n",
2052                               idx));
2053         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2054     }
2055     /* Get function pointer hidden within datasv        */
2056     funcp = (filter_t)IoANY(datasv);
2057     DEBUG_P(PerlIO_printf(Perl_debug_log,
2058                           "filter_read %d: via function %p (%s)\n",
2059                           idx, funcp, SvPV_nolen(datasv)));
2060     /* Call function. The function is expected to       */
2061     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2062     /* Return: <0:error, =0:eof, >0:not eof             */
2063     return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2064 }
2065
2066 STATIC char *
2067 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2068 {
2069 #ifdef PERL_CR_FILTER
2070     if (!PL_rsfp_filters) {
2071         filter_add(S_cr_textfilter,NULL);
2072     }
2073 #endif
2074     if (PL_rsfp_filters) {
2075
2076         if (!append)
2077             SvCUR_set(sv, 0);   /* start with empty line        */
2078         if (FILTER_READ(0, sv, 0) > 0)
2079             return ( SvPVX(sv) ) ;
2080         else
2081             return Nullch ;
2082     }
2083     else
2084         return (sv_gets(sv, fp, append));
2085 }
2086
2087 STATIC HV *
2088 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2089 {
2090     GV *gv;
2091
2092     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2093         return PL_curstash;
2094
2095     if (len > 2 &&
2096         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2097         (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2098     {
2099         return GvHV(gv);                        /* Foo:: */
2100     }
2101
2102     /* use constant CLASS => 'MyClass' */
2103     if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2104         SV *sv;
2105         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2106             pkgname = SvPV_nolen(sv);
2107         }
2108     }
2109
2110     return gv_stashpv(pkgname, FALSE);
2111 }
2112
2113 #ifdef DEBUGGING
2114     static char* exp_name[] =
2115         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2116           "ATTRTERM", "TERMBLOCK"
2117         };
2118 #endif
2119
2120 /*
2121   yylex
2122
2123   Works out what to call the token just pulled out of the input
2124   stream.  The yacc parser takes care of taking the ops we return and
2125   stitching them into a tree.
2126
2127   Returns:
2128     PRIVATEREF
2129
2130   Structure:
2131       if read an identifier
2132           if we're in a my declaration
2133               croak if they tried to say my($foo::bar)
2134               build the ops for a my() declaration
2135           if it's an access to a my() variable
2136               are we in a sort block?
2137                   croak if my($a); $a <=> $b
2138               build ops for access to a my() variable
2139           if in a dq string, and they've said @foo and we can't find @foo
2140               croak
2141           build ops for a bareword
2142       if we already built the token before, use it.
2143 */
2144
2145 #ifdef USE_PURE_BISON
2146 int
2147 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2148 {
2149     int r;
2150
2151     yyactlevel++;
2152     yylval_pointer[yyactlevel] = lvalp;
2153     yychar_pointer[yyactlevel] = lcharp;
2154     if (yyactlevel >= YYMAXLEVEL)
2155         Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2156
2157     r = Perl_yylex(aTHX);
2158
2159     if (yyactlevel > 0)
2160        yyactlevel--;
2161
2162     return r;
2163 }
2164 #endif
2165
2166 #ifdef __SC__
2167 #pragma segment Perl_yylex
2168 #endif
2169 int
2170 Perl_yylex(pTHX)
2171 {
2172     register char *s;
2173     register char *d;
2174     register I32 tmp;
2175     STRLEN len;
2176     GV *gv = Nullgv;
2177     GV **gvp = 0;
2178     bool bof = FALSE;
2179
2180     /* check if there's an identifier for us to look at */
2181     if (PL_pending_ident) 
2182         return S_pending_ident(aTHX);
2183
2184     /* no identifier pending identification */
2185
2186     switch (PL_lex_state) {
2187 #ifdef COMMENTARY
2188     case LEX_NORMAL:            /* Some compilers will produce faster */
2189     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2190         break;
2191 #endif
2192
2193     /* when we've already built the next token, just pull it out of the queue */
2194     case LEX_KNOWNEXT:
2195         PL_nexttoke--;
2196         yylval = PL_nextval[PL_nexttoke];
2197         if (!PL_nexttoke) {
2198             PL_lex_state = PL_lex_defer;
2199             PL_expect = PL_lex_expect;
2200             PL_lex_defer = LEX_NORMAL;
2201         }
2202         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2203               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2204               (IV)PL_nexttype[PL_nexttoke]); });
2205
2206         return(PL_nexttype[PL_nexttoke]);
2207
2208     /* interpolated case modifiers like \L \U, including \Q and \E.
2209        when we get here, PL_bufptr is at the \
2210     */
2211     case LEX_INTERPCASEMOD:
2212 #ifdef DEBUGGING
2213         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2214             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2215 #endif
2216         /* handle \E or end of string */
2217         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2218             char oldmod;
2219
2220             /* if at a \E */
2221             if (PL_lex_casemods) {
2222                 oldmod = PL_lex_casestack[--PL_lex_casemods];
2223                 PL_lex_casestack[PL_lex_casemods] = '\0';
2224
2225                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2226                     PL_bufptr += 2;
2227                     PL_lex_state = LEX_INTERPCONCAT;
2228                 }
2229                 return ')';
2230             }
2231             if (PL_bufptr != PL_bufend)
2232                 PL_bufptr += 2;
2233             PL_lex_state = LEX_INTERPCONCAT;
2234             return yylex();
2235         }
2236         else {
2237             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2238               "### Saw case modifier at '%s'\n", PL_bufptr); });
2239             s = PL_bufptr + 1;
2240             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2241                 tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
2242             if (strchr("LU", *s) &&
2243                 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2244             {
2245                 PL_lex_casestack[--PL_lex_casemods] = '\0';
2246                 return ')';
2247             }
2248             if (PL_lex_casemods > 10) {
2249                 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2250                 if (newlb != PL_lex_casestack) {
2251                     SAVEFREEPV(newlb);
2252                     PL_lex_casestack = newlb;
2253                 }
2254             }
2255             PL_lex_casestack[PL_lex_casemods++] = *s;
2256             PL_lex_casestack[PL_lex_casemods] = '\0';
2257             PL_lex_state = LEX_INTERPCONCAT;
2258             PL_nextval[PL_nexttoke].ival = 0;
2259             force_next('(');
2260             if (*s == 'l')
2261                 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2262             else if (*s == 'u')
2263                 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2264             else if (*s == 'L')
2265                 PL_nextval[PL_nexttoke].ival = OP_LC;
2266             else if (*s == 'U')
2267                 PL_nextval[PL_nexttoke].ival = OP_UC;
2268             else if (*s == 'Q')
2269                 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2270             else
2271                 Perl_croak(aTHX_ "panic: yylex");
2272             PL_bufptr = s + 1;
2273             force_next(FUNC);
2274             if (PL_lex_starts) {
2275                 s = PL_bufptr;
2276                 PL_lex_starts = 0;
2277                 Aop(OP_CONCAT);
2278             }
2279             else
2280                 return yylex();
2281         }
2282
2283     case LEX_INTERPPUSH:
2284         return sublex_push();
2285
2286     case LEX_INTERPSTART:
2287         if (PL_bufptr == PL_bufend)
2288             return sublex_done();
2289         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2290               "### Interpolated variable at '%s'\n", PL_bufptr); });
2291         PL_expect = XTERM;
2292         PL_lex_dojoin = (*PL_bufptr == '@');
2293         PL_lex_state = LEX_INTERPNORMAL;
2294         if (PL_lex_dojoin) {
2295             PL_nextval[PL_nexttoke].ival = 0;
2296             force_next(',');
2297 #ifdef USE_5005THREADS
2298             PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2299             PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2300             force_next(PRIVATEREF);
2301 #else
2302             force_ident("\"", '$');
2303 #endif /* USE_5005THREADS */
2304             PL_nextval[PL_nexttoke].ival = 0;
2305             force_next('$');
2306             PL_nextval[PL_nexttoke].ival = 0;
2307             force_next('(');
2308             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2309             force_next(FUNC);
2310         }
2311         if (PL_lex_starts++) {
2312             s = PL_bufptr;
2313             Aop(OP_CONCAT);
2314         }
2315         return yylex();
2316
2317     case LEX_INTERPENDMAYBE:
2318         if (intuit_more(PL_bufptr)) {
2319             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2320             break;
2321         }
2322         /* FALL THROUGH */
2323
2324     case LEX_INTERPEND:
2325         if (PL_lex_dojoin) {
2326             PL_lex_dojoin = FALSE;
2327             PL_lex_state = LEX_INTERPCONCAT;
2328             return ')';
2329         }
2330         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2331             && SvEVALED(PL_lex_repl))
2332         {
2333             if (PL_bufptr != PL_bufend)
2334                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2335             PL_lex_repl = Nullsv;
2336         }
2337         /* FALLTHROUGH */
2338     case LEX_INTERPCONCAT:
2339 #ifdef DEBUGGING
2340         if (PL_lex_brackets)
2341             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2342 #endif
2343         if (PL_bufptr == PL_bufend)
2344             return sublex_done();
2345
2346         if (SvIVX(PL_linestr) == '\'') {
2347             SV *sv = newSVsv(PL_linestr);
2348             if (!PL_lex_inpat)
2349                 sv = tokeq(sv);
2350             else if ( PL_hints & HINT_NEW_RE )
2351                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2352             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2353             s = PL_bufend;
2354         }
2355         else {
2356             s = scan_const(PL_bufptr);
2357             if (*s == '\\')
2358                 PL_lex_state = LEX_INTERPCASEMOD;
2359             else
2360                 PL_lex_state = LEX_INTERPSTART;
2361         }
2362
2363         if (s != PL_bufptr) {
2364             PL_nextval[PL_nexttoke] = yylval;
2365             PL_expect = XTERM;
2366             force_next(THING);
2367             if (PL_lex_starts++)
2368                 Aop(OP_CONCAT);
2369             else {
2370                 PL_bufptr = s;
2371                 return yylex();
2372             }
2373         }
2374
2375         return yylex();
2376     case LEX_FORMLINE:
2377         PL_lex_state = LEX_NORMAL;
2378         s = scan_formline(PL_bufptr);
2379         if (!PL_lex_formbrack)
2380             goto rightbracket;
2381         OPERATOR(';');
2382     }
2383
2384     s = PL_bufptr;
2385     PL_oldoldbufptr = PL_oldbufptr;
2386     PL_oldbufptr = s;
2387     DEBUG_T( {
2388         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2389                       exp_name[PL_expect], s);
2390     } );
2391
2392   retry:
2393     switch (*s) {
2394     default:
2395         if (isIDFIRST_lazy_if(s,UTF))
2396             goto keylookup;
2397         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2398     case 4:
2399     case 26:
2400         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2401     case 0:
2402         if (!PL_rsfp) {
2403             PL_last_uni = 0;
2404             PL_last_lop = 0;
2405             if (PL_lex_brackets)
2406                 yyerror("Missing right curly or square bracket");
2407             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2408                         "### Tokener got EOF\n");
2409             } );
2410             TOKEN(0);
2411         }
2412         if (s++ < PL_bufend)
2413             goto retry;                 /* ignore stray nulls */
2414         PL_last_uni = 0;
2415         PL_last_lop = 0;
2416         if (!PL_in_eval && !PL_preambled) {
2417             PL_preambled = TRUE;
2418             sv_setpv(PL_linestr,incl_perldb());
2419             if (SvCUR(PL_linestr))
2420                 sv_catpv(PL_linestr,";");
2421             if (PL_preambleav){
2422                 while(AvFILLp(PL_preambleav) >= 0) {
2423                     SV *tmpsv = av_shift(PL_preambleav);
2424                     sv_catsv(PL_linestr, tmpsv);
2425                     sv_catpv(PL_linestr, ";");
2426                     sv_free(tmpsv);
2427                 }
2428                 sv_free((SV*)PL_preambleav);
2429                 PL_preambleav = NULL;
2430             }
2431             if (PL_minus_n || PL_minus_p) {
2432                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2433                 if (PL_minus_l)
2434                     sv_catpv(PL_linestr,"chomp;");
2435                 if (PL_minus_a) {
2436                     if (PL_minus_F) {
2437                         if (strchr("/'\"", *PL_splitstr)
2438                               && strchr(PL_splitstr + 1, *PL_splitstr))
2439                             Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
2440                         else {
2441                             char delim;
2442                             s = "'~#\200\1'"; /* surely one char is unused...*/
2443                             while (s[1] && strchr(PL_splitstr, *s))  s++;
2444                             delim = *s;
2445                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2446                                       "q" + (delim == '\''), delim);
2447                             for (s = PL_splitstr; *s; s++) {
2448                                 if (*s == '\\')
2449                                     sv_catpvn(PL_linestr, "\\", 1);
2450                                 sv_catpvn(PL_linestr, s, 1);
2451                             }
2452                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2453                         }
2454                     }
2455                     else
2456                         sv_catpv(PL_linestr,"our @F=split(' ');");
2457                 }
2458             }
2459             sv_catpv(PL_linestr, "\n");
2460             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2461             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2462             PL_last_lop = PL_last_uni = Nullch;
2463             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2464                 SV *sv = NEWSV(85,0);
2465
2466                 sv_upgrade(sv, SVt_PVMG);
2467                 sv_setsv(sv,PL_linestr);
2468                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2469             }
2470             goto retry;
2471         }
2472         do {
2473             bof = PL_rsfp ? TRUE : FALSE;
2474             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2475               fake_eof:
2476                 if (PL_rsfp) {
2477                     if (PL_preprocess && !PL_in_eval)
2478                         (void)PerlProc_pclose(PL_rsfp);
2479                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2480                         PerlIO_clearerr(PL_rsfp);
2481                     else
2482                         (void)PerlIO_close(PL_rsfp);
2483                     PL_rsfp = Nullfp;
2484                     PL_doextract = FALSE;
2485                 }
2486                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2487                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2488                     sv_catpv(PL_linestr,";}");
2489                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2490                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2491                     PL_last_lop = PL_last_uni = Nullch;
2492                     PL_minus_n = PL_minus_p = 0;
2493                     goto retry;
2494                 }
2495                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2496                 PL_last_lop = PL_last_uni = Nullch;
2497                 sv_setpv(PL_linestr,"");
2498                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2499             }
2500             /* if it looks like the start of a BOM, check if it in fact is */
2501             else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2502 #ifdef PERLIO_IS_STDIO
2503 #  ifdef __GNU_LIBRARY__
2504 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2505 #      define FTELL_FOR_PIPE_IS_BROKEN
2506 #    endif
2507 #  else
2508 #    ifdef __GLIBC__
2509 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2510 #        define FTELL_FOR_PIPE_IS_BROKEN
2511 #      endif
2512 #    endif
2513 #  endif
2514 #endif
2515 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2516                 /* This loses the possibility to detect the bof
2517                  * situation on perl -P when the libc5 is being used.
2518                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2519                  */
2520                 if (!PL_preprocess)
2521                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2522 #else
2523                 bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2524 #endif
2525                 if (bof) {
2526                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2527                     s = swallow_bom((U8*)s);
2528                 }
2529             }
2530             if (PL_doextract) {
2531                 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2532                     PL_doextract = FALSE;
2533
2534                 /* Incest with pod. */
2535                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2536                     sv_setpv(PL_linestr, "");
2537                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2538                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2539                     PL_last_lop = PL_last_uni = Nullch;
2540                     PL_doextract = FALSE;
2541                 }
2542             }
2543             incline(s);
2544         } while (PL_doextract);
2545         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2546         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2547             SV *sv = NEWSV(85,0);
2548
2549             sv_upgrade(sv, SVt_PVMG);
2550             sv_setsv(sv,PL_linestr);
2551             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2552         }
2553         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2554         PL_last_lop = PL_last_uni = Nullch;
2555         if (CopLINE(PL_curcop) == 1) {
2556             while (s < PL_bufend && isSPACE(*s))
2557                 s++;
2558             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2559                 s++;
2560             d = Nullch;
2561             if (!PL_in_eval) {
2562                 if (*s == '#' && *(s+1) == '!')
2563                     d = s + 2;
2564 #ifdef ALTERNATE_SHEBANG
2565                 else {
2566                     static char as[] = ALTERNATE_SHEBANG;
2567                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2568                         d = s + (sizeof(as) - 1);
2569                 }
2570 #endif /* ALTERNATE_SHEBANG */
2571             }
2572             if (d) {
2573                 char *ipath;
2574                 char *ipathend;
2575
2576                 while (isSPACE(*d))
2577                     d++;
2578                 ipath = d;
2579                 while (*d && !isSPACE(*d))
2580                     d++;
2581                 ipathend = d;
2582
2583 #ifdef ARG_ZERO_IS_SCRIPT
2584                 if (ipathend > ipath) {
2585                     /*
2586                      * HP-UX (at least) sets argv[0] to the script name,
2587                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2588                      * at least, set argv[0] to the basename of the Perl
2589                      * interpreter. So, having found "#!", we'll set it right.
2590                      */
2591                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2592                     assert(SvPOK(x) || SvGMAGICAL(x));
2593                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2594                         sv_setpvn(x, ipath, ipathend - ipath);
2595                         SvSETMAGIC(x);
2596                     }
2597                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2598                 }
2599 #endif /* ARG_ZERO_IS_SCRIPT */
2600
2601                 /*
2602                  * Look for options.
2603                  */
2604                 d = instr(s,"perl -");
2605                 if (!d) {
2606                     d = instr(s,"perl");
2607 #if defined(DOSISH)
2608                     /* avoid getting into infinite loops when shebang
2609                      * line contains "Perl" rather than "perl" */
2610                     if (!d) {
2611                         for (d = ipathend-4; d >= ipath; --d) {
2612                             if ((*d == 'p' || *d == 'P')
2613                                 && !ibcmp(d, "perl", 4))
2614                             {
2615                                 break;
2616                             }
2617                         }
2618                         if (d < ipath)
2619                             d = Nullch;
2620                     }
2621 #endif
2622                 }
2623 #ifdef ALTERNATE_SHEBANG
2624                 /*
2625                  * If the ALTERNATE_SHEBANG on this system starts with a
2626                  * character that can be part of a Perl expression, then if
2627                  * we see it but not "perl", we're probably looking at the
2628                  * start of Perl code, not a request to hand off to some
2629                  * other interpreter.  Similarly, if "perl" is there, but
2630                  * not in the first 'word' of the line, we assume the line
2631                  * contains the start of the Perl program.
2632                  */
2633                 if (d && *s != '#') {
2634                     char *c = ipath;
2635                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2636                         c++;
2637                     if (c < d)
2638                         d = Nullch;     /* "perl" not in first word; ignore */
2639                     else
2640                         *s = '#';       /* Don't try to parse shebang line */
2641                 }
2642 #endif /* ALTERNATE_SHEBANG */
2643 #ifndef MACOS_TRADITIONAL
2644                 if (!d &&
2645                     *s == '#' &&
2646                     ipathend > ipath &&
2647                     !PL_minus_c &&
2648                     !instr(s,"indir") &&
2649                     instr(PL_origargv[0],"perl"))
2650                 {
2651                     char **newargv;
2652
2653                     *ipathend = '\0';
2654                     s = ipathend + 1;
2655                     while (s < PL_bufend && isSPACE(*s))
2656                         s++;
2657                     if (s < PL_bufend) {
2658                         Newz(899,newargv,PL_origargc+3,char*);
2659                         newargv[1] = s;
2660                         while (s < PL_bufend && !isSPACE(*s))
2661                             s++;
2662                         *s = '\0';
2663                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2664                     }
2665                     else
2666                         newargv = PL_origargv;
2667                     newargv[0] = ipath;
2668                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2669                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2670                 }
2671 #endif
2672                 if (d) {
2673                     U32 oldpdb = PL_perldb;
2674                     bool oldn = PL_minus_n;
2675                     bool oldp = PL_minus_p;
2676
2677                     while (*d && !isSPACE(*d)) d++;
2678                     while (SPACE_OR_TAB(*d)) d++;
2679
2680                     if (*d++ == '-') {
2681                         do {
2682                             if (*d == 'M' || *d == 'm') {
2683                                 char *m = d;
2684                                 while (*d && !isSPACE(*d)) d++;
2685                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2686                                       (int)(d - m), m);
2687                             }
2688                             d = moreswitches(d);
2689                         } while (d);
2690                         if ((PERLDB_LINE && !oldpdb) ||
2691                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2692                               /* if we have already added "LINE: while (<>) {",
2693                                  we must not do it again */
2694                         {
2695                             sv_setpv(PL_linestr, "");
2696                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2697                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2698                             PL_last_lop = PL_last_uni = Nullch;
2699                             PL_preambled = FALSE;
2700                             if (PERLDB_LINE)
2701                                 (void)gv_fetchfile(PL_origfilename);
2702                             goto retry;
2703                         }
2704                     }
2705                 }
2706             }
2707         }
2708         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2709             PL_bufptr = s;
2710             PL_lex_state = LEX_FORMLINE;
2711             return yylex();
2712         }
2713         goto retry;
2714     case '\r':
2715 #ifdef PERL_STRICT_CR
2716         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2717         Perl_croak(aTHX_
2718       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2719 #endif
2720     case ' ': case '\t': case '\f': case 013:
2721 #ifdef MACOS_TRADITIONAL
2722     case '\312':
2723 #endif
2724         s++;
2725         goto retry;
2726     case '#':
2727     case '\n':
2728         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2729             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2730                 /* handle eval qq[#line 1 "foo"\n ...] */
2731                 CopLINE_dec(PL_curcop);
2732                 incline(s);
2733             }
2734             d = PL_bufend;
2735             while (s < d && *s != '\n')
2736                 s++;
2737             if (s < d)
2738                 s++;
2739             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2740               Perl_croak(aTHX_ "panic: input overflow");
2741             incline(s);
2742             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2743                 PL_bufptr = s;
2744                 PL_lex_state = LEX_FORMLINE;
2745                 return yylex();
2746             }
2747         }
2748         else {
2749             *s = '\0';
2750             PL_bufend = s;
2751         }
2752         goto retry;
2753     case '-':
2754         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2755             I32 ftst = 0;
2756
2757             s++;
2758             PL_bufptr = s;
2759             tmp = *s++;
2760
2761             while (s < PL_bufend && SPACE_OR_TAB(*s))
2762                 s++;
2763
2764             if (strnEQ(s,"=>",2)) {
2765                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2766                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2767                             "### Saw unary minus before =>, forcing word '%s'\n", s);
2768                 } );
2769                 OPERATOR('-');          /* unary minus */
2770             }
2771             PL_last_uni = PL_oldbufptr;
2772             switch (tmp) {
2773             case 'r': ftst = OP_FTEREAD;        break;
2774             case 'w': ftst = OP_FTEWRITE;       break;
2775             case 'x': ftst = OP_FTEEXEC;        break;
2776             case 'o': ftst = OP_FTEOWNED;       break;
2777             case 'R': ftst = OP_FTRREAD;        break;
2778             case 'W': ftst = OP_FTRWRITE;       break;
2779             case 'X': ftst = OP_FTREXEC;        break;
2780             case 'O': ftst = OP_FTROWNED;       break;
2781             case 'e': ftst = OP_FTIS;           break;
2782             case 'z': ftst = OP_FTZERO;         break;
2783             case 's': ftst = OP_FTSIZE;         break;
2784             case 'f': ftst = OP_FTFILE;         break;
2785             case 'd': ftst = OP_FTDIR;          break;
2786             case 'l': ftst = OP_FTLINK;         break;
2787             case 'p': ftst = OP_FTPIPE;         break;
2788             case 'S': ftst = OP_FTSOCK;         break;
2789             case 'u': ftst = OP_FTSUID;         break;
2790             case 'g': ftst = OP_FTSGID;         break;
2791             case 'k': ftst = OP_FTSVTX;         break;
2792             case 'b': ftst = OP_FTBLK;          break;
2793             case 'c': ftst = OP_FTCHR;          break;
2794             case 't': ftst = OP_FTTTY;          break;
2795             case 'T': ftst = OP_FTTEXT;         break;
2796             case 'B': ftst = OP_FTBINARY;       break;
2797             case 'M': case 'A': case 'C':
2798                 gv_fetchpv("\024",TRUE, SVt_PV);
2799                 switch (tmp) {
2800                 case 'M': ftst = OP_FTMTIME;    break;
2801                 case 'A': ftst = OP_FTATIME;    break;
2802                 case 'C': ftst = OP_FTCTIME;    break;
2803                 default:                        break;
2804                 }
2805                 break;
2806             default:
2807                 break;
2808             }
2809             if (ftst) {
2810                 PL_last_lop_op = ftst;
2811                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2812                         "### Saw file test %c\n", (int)ftst);
2813                 } );
2814                 FTST(ftst);
2815             }
2816             else {
2817                 /* Assume it was a minus followed by a one-letter named
2818                  * subroutine call (or a -bareword), then. */
2819                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2820                         "### %c looked like a file test but was not\n",
2821                         (int)ftst);
2822                 } );
2823                 s -= 2;
2824             }
2825         }
2826         tmp = *s++;
2827         if (*s == tmp) {
2828             s++;
2829             if (PL_expect == XOPERATOR)
2830                 TERM(POSTDEC);
2831             else
2832                 OPERATOR(PREDEC);
2833         }
2834         else if (*s == '>') {
2835             s++;
2836             s = skipspace(s);
2837             if (isIDFIRST_lazy_if(s,UTF)) {
2838                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2839                 TOKEN(ARROW);
2840             }
2841             else if (*s == '$')
2842                 OPERATOR(ARROW);
2843             else
2844                 TERM(ARROW);
2845         }
2846         if (PL_expect == XOPERATOR)
2847             Aop(OP_SUBTRACT);
2848         else {
2849             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2850                 check_uni();
2851             OPERATOR('-');              /* unary minus */
2852         }
2853
2854     case '+':
2855         tmp = *s++;
2856         if (*s == tmp) {
2857             s++;
2858             if (PL_expect == XOPERATOR)
2859                 TERM(POSTINC);
2860             else
2861                 OPERATOR(PREINC);
2862         }
2863         if (PL_expect == XOPERATOR)
2864             Aop(OP_ADD);
2865         else {
2866             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2867                 check_uni();
2868             OPERATOR('+');
2869         }
2870
2871     case '*':
2872         if (PL_expect != XOPERATOR) {
2873             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2874             PL_expect = XOPERATOR;
2875             force_ident(PL_tokenbuf, '*');
2876             if (!*PL_tokenbuf)
2877                 PREREF('*');
2878             TERM('*');
2879         }
2880         s++;
2881         if (*s == '*') {
2882             s++;
2883             PWop(OP_POW);
2884         }
2885         Mop(OP_MULTIPLY);
2886
2887     case '%':
2888         if (PL_expect == XOPERATOR) {
2889             ++s;
2890             Mop(OP_MODULO);
2891         }
2892         PL_tokenbuf[0] = '%';
2893         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2894         if (!PL_tokenbuf[1]) {
2895             if (s == PL_bufend)
2896                 yyerror("Final % should be \\% or %name");
2897             PREREF('%');
2898         }
2899         PL_pending_ident = '%';
2900         TERM('%');
2901
2902     case '^':
2903         s++;
2904         BOop(OP_BIT_XOR);
2905     case '[':
2906         PL_lex_brackets++;
2907         /* FALL THROUGH */
2908     case '~':
2909     case ',':
2910         tmp = *s++;
2911         OPERATOR(tmp);
2912     case ':':
2913         if (s[1] == ':') {
2914             len = 0;
2915             goto just_a_word;
2916         }
2917         s++;
2918         switch (PL_expect) {
2919             OP *attrs;
2920         case XOPERATOR:
2921             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2922                 break;
2923             PL_bufptr = s;      /* update in case we back off */
2924             goto grabattrs;
2925         case XATTRBLOCK:
2926             PL_expect = XBLOCK;
2927             goto grabattrs;
2928         case XATTRTERM:
2929             PL_expect = XTERMBLOCK;
2930          grabattrs:
2931             s = skipspace(s);
2932             attrs = Nullop;
2933             while (isIDFIRST_lazy_if(s,UTF)) {
2934                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2935                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2936                     if (tmp < 0) tmp = -tmp;
2937                     switch (tmp) {
2938                     case KEY_or:
2939                     case KEY_and:
2940                     case KEY_for:
2941                     case KEY_unless:
2942                     case KEY_if:
2943                     case KEY_while:
2944                     case KEY_until:
2945                         goto got_attrs;
2946                     default:
2947                         break;
2948                     }
2949                 }
2950                 if (*d == '(') {
2951                     d = scan_str(d,TRUE,TRUE);
2952                     if (!d) {
2953                         /* MUST advance bufptr here to avoid bogus
2954                            "at end of line" context messages from yyerror().
2955                          */
2956                         PL_bufptr = s + len;
2957                         yyerror("Unterminated attribute parameter in attribute list");
2958                         if (attrs)
2959                             op_free(attrs);
2960                         return 0;       /* EOF indicator */
2961                     }
2962                 }
2963                 if (PL_lex_stuff) {
2964                     SV *sv = newSVpvn(s, len);
2965                     sv_catsv(sv, PL_lex_stuff);
2966                     attrs = append_elem(OP_LIST, attrs,
2967                                         newSVOP(OP_CONST, 0, sv));
2968                     SvREFCNT_dec(PL_lex_stuff);
2969                     PL_lex_stuff = Nullsv;
2970                 }
2971                 else {
2972                     if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
2973                         CvLVALUE_on(PL_compcv);
2974                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
2975                         CvLOCKED_on(PL_compcv);
2976                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
2977                         CvMETHOD_on(PL_compcv);
2978 #ifdef USE_ITHREADS
2979       else if (PL_in_my == KEY_our && len == 6 && strnEQ(s, "unique", len))
2980                         GvUNIQUE_on(cGVOPx_gv(yylval.opval));
2981 #endif
2982                     /* After we've set the flags, it could be argued that
2983                        we don't need to do the attributes.pm-based setting
2984                        process, and shouldn't bother appending recognized
2985                        flags. To experiment with that, uncomment the
2986                        following "else": */
2987                     else
2988                         attrs = append_elem(OP_LIST, attrs,
2989                                             newSVOP(OP_CONST, 0,
2990                                                     newSVpvn(s, len)));
2991                 }
2992                 s = skipspace(d);
2993                 if (*s == ':' && s[1] != ':')
2994                     s = skipspace(s+1);
2995                 else if (s == d)
2996                     break;      /* require real whitespace or :'s */
2997             }
2998             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
2999             if (*s != ';' && *s != tmp && (tmp != '=' || *s != ')')) {
3000                 char q = ((*s == '\'') ? '"' : '\'');
3001                 /* If here for an expression, and parsed no attrs, back off. */
3002                 if (tmp == '=' && !attrs) {
3003                     s = PL_bufptr;
3004                     break;
3005                 }
3006                 /* MUST advance bufptr here to avoid bogus "at end of line"
3007                    context messages from yyerror().
3008                  */
3009                 PL_bufptr = s;
3010                 if (!*s)
3011                     yyerror("Unterminated attribute list");
3012                 else
3013                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3014                                       q, *s, q));
3015                 if (attrs)
3016                     op_free(attrs);
3017                 OPERATOR(':');
3018             }
3019         got_attrs:
3020             if (attrs) {
3021                 PL_nextval[PL_nexttoke].opval = attrs;
3022                 force_next(THING);
3023             }
3024             TOKEN(COLONATTR);
3025         }
3026         OPERATOR(':');
3027     case '(':
3028         s++;
3029         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3030             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3031         else
3032             PL_expect = XTERM;
3033         TOKEN('(');
3034     case ';':
3035         CLINE;
3036         tmp = *s++;
3037         OPERATOR(tmp);
3038     case ')':
3039         tmp = *s++;
3040         s = skipspace(s);
3041         if (*s == '{')
3042             PREBLOCK(tmp);
3043         TERM(tmp);
3044     case ']':
3045         s++;
3046         if (PL_lex_brackets <= 0)
3047             yyerror("Unmatched right square bracket");
3048         else
3049             --PL_lex_brackets;
3050         if (PL_lex_state == LEX_INTERPNORMAL) {
3051             if (PL_lex_brackets == 0) {
3052                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3053                     PL_lex_state = LEX_INTERPEND;
3054             }
3055         }
3056         TERM(']');
3057     case '{':
3058       leftbracket:
3059         s++;
3060         if (PL_lex_brackets > 100) {
3061             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3062             if (newlb != PL_lex_brackstack) {
3063                 SAVEFREEPV(newlb);
3064                 PL_lex_brackstack = newlb;
3065             }
3066         }
3067         switch (PL_expect) {
3068         case XTERM:
3069             if (PL_lex_formbrack) {
3070                 s--;
3071                 PRETERMBLOCK(DO);
3072             }
3073             if (PL_oldoldbufptr == PL_last_lop)
3074                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3075             else
3076                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3077             OPERATOR(HASHBRACK);
3078         case XOPERATOR:
3079             while (s < PL_bufend && SPACE_OR_TAB(*s))
3080                 s++;
3081             d = s;
3082             PL_tokenbuf[0] = '\0';
3083             if (d < PL_bufend && *d == '-') {
3084                 PL_tokenbuf[0] = '-';
3085                 d++;
3086                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3087                     d++;
3088             }
3089             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3090                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3091                               FALSE, &len);
3092                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3093                     d++;
3094                 if (*d == '}') {
3095                     char minus = (PL_tokenbuf[0] == '-');
3096                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3097                     if (minus)
3098                         force_next('-');
3099                 }
3100             }
3101             /* FALL THROUGH */
3102         case XATTRBLOCK:
3103         case XBLOCK:
3104             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3105             PL_expect = XSTATE;
3106             break;
3107         case XATTRTERM:
3108         case XTERMBLOCK:
3109             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3110             PL_expect = XSTATE;
3111             break;
3112         default: {
3113                 char *t;
3114                 if (PL_oldoldbufptr == PL_last_lop)
3115                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3116                 else
3117                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3118                 s = skipspace(s);
3119                 if (*s == '}') {
3120                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3121                         PL_expect = XTERM;
3122                         /* This hack is to get the ${} in the message. */
3123                         PL_bufptr = s+1;
3124                         yyerror("syntax error");
3125                         break;
3126                     }
3127                     OPERATOR(HASHBRACK);
3128                 }
3129                 /* This hack serves to disambiguate a pair of curlies
3130                  * as being a block or an anon hash.  Normally, expectation
3131                  * determines that, but in cases where we're not in a
3132                  * position to expect anything in particular (like inside
3133                  * eval"") we have to resolve the ambiguity.  This code
3134                  * covers the case where the first term in the curlies is a
3135                  * quoted string.  Most other cases need to be explicitly
3136                  * disambiguated by prepending a `+' before the opening
3137                  * curly in order to force resolution as an anon hash.
3138                  *
3139                  * XXX should probably propagate the outer expectation
3140                  * into eval"" to rely less on this hack, but that could
3141                  * potentially break current behavior of eval"".
3142                  * GSAR 97-07-21
3143                  */
3144                 t = s;
3145                 if (*s == '\'' || *s == '"' || *s == '`') {
3146                     /* common case: get past first string, handling escapes */
3147                     for (t++; t < PL_bufend && *t != *s;)
3148                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3149                             t++;
3150                     t++;
3151                 }
3152                 else if (*s == 'q') {
3153                     if (++t < PL_bufend
3154                         && (!isALNUM(*t)
3155                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3156                                 && !isALNUM(*t))))
3157                     {
3158                         char *tmps;
3159                         char open, close, term;
3160                         I32 brackets = 1;
3161
3162                         while (t < PL_bufend && isSPACE(*t))
3163                             t++;
3164                         term = *t;
3165                         open = term;
3166                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3167                             term = tmps[5];
3168                         close = term;
3169                         if (open == close)
3170                             for (t++; t < PL_bufend; t++) {
3171                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3172                                     t++;
3173                                 else if (*t == open)
3174                                     break;
3175                             }
3176                         else
3177                             for (t++; t < PL_bufend; t++) {
3178                                 if (*t == '\\' && t+1 < PL_bufend)
3179                                     t++;
3180                                 else if (*t == close && --brackets <= 0)
3181                                     break;
3182                                 else if (*t == open)
3183                                     brackets++;
3184                             }
3185                     }
3186                     t++;
3187                 }
3188                 else if (isALNUM_lazy_if(t,UTF)) {
3189                     t += UTF8SKIP(t);
3190                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3191                          t += UTF8SKIP(t);
3192                 }
3193                 while (t < PL_bufend && isSPACE(*t))
3194                     t++;
3195                 /* if comma follows first term, call it an anon hash */
3196                 /* XXX it could be a comma expression with loop modifiers */
3197                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3198                                    || (*t == '=' && t[1] == '>')))
3199                     OPERATOR(HASHBRACK);
3200                 if (PL_expect == XREF)
3201                     PL_expect = XTERM;
3202                 else {
3203                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3204                     PL_expect = XSTATE;
3205                 }
3206             }
3207             break;
3208         }
3209         yylval.ival = CopLINE(PL_curcop);
3210         if (isSPACE(*s) || *s == '#')
3211             PL_copline = NOLINE;   /* invalidate current command line number */
3212         TOKEN('{');
3213     case '}':
3214       rightbracket:
3215         s++;
3216         if (PL_lex_brackets <= 0)
3217             yyerror("Unmatched right curly bracket");
3218         else
3219             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3220         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3221             PL_lex_formbrack = 0;
3222         if (PL_lex_state == LEX_INTERPNORMAL) {
3223             if (PL_lex_brackets == 0) {
3224                 if (PL_expect & XFAKEBRACK) {
3225                     PL_expect &= XENUMMASK;
3226                     PL_lex_state = LEX_INTERPEND;
3227                     PL_bufptr = s;
3228                     return yylex();     /* ignore fake brackets */
3229                 }
3230                 if (*s == '-' && s[1] == '>')
3231                     PL_lex_state = LEX_INTERPENDMAYBE;
3232                 else if (*s != '[' && *s != '{')
3233                     PL_lex_state = LEX_INTERPEND;
3234             }
3235         }
3236         if (PL_expect & XFAKEBRACK) {
3237             PL_expect &= XENUMMASK;
3238             PL_bufptr = s;
3239             return yylex();             /* ignore fake brackets */
3240         }
3241         force_next('}');
3242         TOKEN(';');
3243     case '&':
3244         s++;
3245         tmp = *s++;
3246         if (tmp == '&')
3247             AOPERATOR(ANDAND);
3248         s--;
3249         if (PL_expect == XOPERATOR) {
3250             if (ckWARN(WARN_SEMICOLON)
3251                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3252             {
3253                 CopLINE_dec(PL_curcop);
3254                 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3255                 CopLINE_inc(PL_curcop);
3256             }
3257             BAop(OP_BIT_AND);
3258         }
3259
3260         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3261         if (*PL_tokenbuf) {
3262             PL_expect = XOPERATOR;
3263             force_ident(PL_tokenbuf, '&');
3264         }
3265         else
3266             PREREF('&');
3267         yylval.ival = (OPpENTERSUB_AMPER<<8);
3268         TERM('&');
3269
3270     case '|':
3271         s++;
3272         tmp = *s++;
3273         if (tmp == '|')
3274             AOPERATOR(OROR);
3275         s--;
3276         BOop(OP_BIT_OR);
3277     case '=':
3278         s++;
3279         tmp = *s++;
3280         if (tmp == '=')
3281             Eop(OP_EQ);
3282         if (tmp == '>')
3283             OPERATOR(',');
3284         if (tmp == '~')
3285             PMop(OP_MATCH);
3286         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3287             Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
3288         s--;
3289         if (PL_expect == XSTATE && isALPHA(tmp) &&
3290                 (s == PL_linestart+1 || s[-2] == '\n') )
3291         {
3292             if (PL_in_eval && !PL_rsfp) {
3293                 d = PL_bufend;
3294                 while (s < d) {
3295                     if (*s++ == '\n') {
3296                         incline(s);
3297                         if (strnEQ(s,"=cut",4)) {
3298                             s = strchr(s,'\n');
3299                             if (s)
3300                                 s++;
3301                             else
3302                                 s = d;
3303                             incline(s);
3304                             goto retry;
3305                         }
3306                     }
3307                 }
3308                 goto retry;
3309             }
3310             s = PL_bufend;
3311             PL_doextract = TRUE;
3312             goto retry;
3313         }
3314         if (PL_lex_brackets < PL_lex_formbrack) {
3315             char *t;
3316 #ifdef PERL_STRICT_CR
3317             for (t = s; SPACE_OR_TAB(*t); t++) ;
3318 #else
3319             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3320 #endif
3321             if (*t == '\n' || *t == '#') {
3322                 s--;
3323                 PL_expect = XBLOCK;
3324                 goto leftbracket;
3325             }
3326         }
3327         yylval.ival = 0;
3328         OPERATOR(ASSIGNOP);
3329     case '!':
3330         s++;
3331         tmp = *s++;
3332         if (tmp == '=')
3333             Eop(OP_NE);
3334         if (tmp == '~')
3335             PMop(OP_NOT);
3336         s--;
3337         OPERATOR('!');
3338     case '<':
3339         if (PL_expect != XOPERATOR) {
3340             if (s[1] != '<' && !strchr(s,'>'))
3341                 check_uni();
3342             if (s[1] == '<')
3343                 s = scan_heredoc(s);
3344             else
3345                 s = scan_inputsymbol(s);
3346             TERM(sublex_start());
3347         }
3348         s++;
3349         tmp = *s++;
3350         if (tmp == '<')
3351             SHop(OP_LEFT_SHIFT);
3352         if (tmp == '=') {
3353             tmp = *s++;
3354             if (tmp == '>')
3355                 Eop(OP_NCMP);
3356             s--;
3357             Rop(OP_LE);
3358         }
3359         s--;
3360         Rop(OP_LT);
3361     case '>':
3362         s++;
3363         tmp = *s++;
3364         if (tmp == '>')
3365             SHop(OP_RIGHT_SHIFT);
3366         if (tmp == '=')
3367             Rop(OP_GE);
3368         s--;
3369         Rop(OP_GT);
3370
3371     case '$':
3372         CLINE;
3373
3374         if (PL_expect == XOPERATOR) {
3375             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3376                 PL_expect = XTERM;
3377                 depcom();
3378                 return ','; /* grandfather non-comma-format format */
3379             }
3380         }
3381
3382         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3383             PL_tokenbuf[0] = '@';
3384             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3385                            sizeof PL_tokenbuf - 1, FALSE);
3386             if (PL_expect == XOPERATOR)
3387                 no_op("Array length", s);
3388             if (!PL_tokenbuf[1])
3389                 PREREF(DOLSHARP);
3390             PL_expect = XOPERATOR;
3391             PL_pending_ident = '#';
3392             TOKEN(DOLSHARP);
3393         }
3394
3395         PL_tokenbuf[0] = '$';
3396         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3397                        sizeof PL_tokenbuf - 1, FALSE);
3398         if (PL_expect == XOPERATOR)
3399             no_op("Scalar", s);
3400         if (!PL_tokenbuf[1]) {
3401             if (s == PL_bufend)
3402                 yyerror("Final $ should be \\$ or $name");
3403             PREREF('$');
3404         }
3405
3406         /* This kludge not intended to be bulletproof. */
3407         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3408             yylval.opval = newSVOP(OP_CONST, 0,
3409                                    newSViv(PL_compiling.cop_arybase));
3410             yylval.opval->op_private = OPpCONST_ARYBASE;
3411             TERM(THING);
3412         }
3413
3414         d = s;
3415         tmp = (I32)*s;
3416         if (PL_lex_state == LEX_NORMAL)
3417             s = skipspace(s);
3418
3419         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3420             char *t;
3421             if (*s == '[') {
3422                 PL_tokenbuf[0] = '@';
3423                 if (ckWARN(WARN_SYNTAX)) {
3424                     for(t = s + 1;
3425                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3426                         t++) ;
3427                     if (*t++ == ',') {
3428                         PL_bufptr = skipspace(PL_bufptr);
3429                         while (t < PL_bufend && *t != ']')
3430                             t++;
3431                         Perl_warner(aTHX_ WARN_SYNTAX,
3432                                 "Multidimensional syntax %.*s not supported",
3433                                 (t - PL_bufptr) + 1, PL_bufptr);
3434                     }
3435                 }
3436             }
3437             else if (*s == '{') {
3438                 PL_tokenbuf[0] = '%';
3439                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3440                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3441                 {
3442                     char tmpbuf[sizeof PL_tokenbuf];
3443                     STRLEN len;
3444                     for (t++; isSPACE(*t); t++) ;
3445                     if (isIDFIRST_lazy_if(t,UTF)) {
3446                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3447                         for (; isSPACE(*t); t++) ;
3448                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3449                             Perl_warner(aTHX_ WARN_SYNTAX,
3450                                 "You need to quote \"%s\"", tmpbuf);
3451                     }
3452                 }
3453             }
3454         }
3455
3456         PL_expect = XOPERATOR;
3457         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3458             bool islop = (PL_last_lop == PL_oldoldbufptr);
3459             if (!islop || PL_last_lop_op == OP_GREPSTART)
3460                 PL_expect = XOPERATOR;
3461             else if (strchr("$@\"'`q", *s))
3462                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3463             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3464                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3465             else if (isIDFIRST_lazy_if(s,UTF)) {
3466                 char tmpbuf[sizeof PL_tokenbuf];
3467                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3468                 if ((tmp = keyword(tmpbuf, len))) {
3469                     /* binary operators exclude handle interpretations */
3470                     switch (tmp) {
3471                     case -KEY_x:
3472                     case -KEY_eq:
3473                     case -KEY_ne:
3474                     case -KEY_gt:
3475                     case -KEY_lt:
3476                     case -KEY_ge:
3477                     case -KEY_le:
3478                     case -KEY_cmp:
3479                         break;
3480                     default:
3481                         PL_expect = XTERM;      /* e.g. print $fh length() */
3482                         break;
3483                     }
3484                 }
3485                 else {
3486                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3487                     if (gv && GvCVu(gv))
3488                         PL_expect = XTERM;      /* e.g. print $fh subr() */
3489                 }
3490             }
3491             else if (isDIGIT(*s))
3492                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3493             else if (*s == '.' && isDIGIT(s[1]))
3494                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3495             else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3496                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3497             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3498                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3499         }
3500         PL_pending_ident = '$';
3501         TOKEN('$');
3502
3503     case '@':
3504         if (PL_expect == XOPERATOR)
3505             no_op("Array", s);
3506         PL_tokenbuf[0] = '@';
3507         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3508         if (!PL_tokenbuf[1]) {
3509             if (s == PL_bufend)
3510                 yyerror("Final @ should be \\@ or @name");
3511             PREREF('@');
3512         }
3513         if (PL_lex_state == LEX_NORMAL)
3514             s = skipspace(s);
3515         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3516             if (*s == '{')
3517                 PL_tokenbuf[0] = '%';
3518
3519             /* Warn about @ where they meant $. */
3520             if (ckWARN(WARN_SYNTAX)) {
3521                 if (*s == '[' || *s == '{') {
3522                     char *t = s + 1;
3523                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3524                         t++;
3525                     if (*t == '}' || *t == ']') {
3526                         t++;
3527                         PL_bufptr = skipspace(PL_bufptr);
3528                         Perl_warner(aTHX_ WARN_SYNTAX,
3529                             "Scalar value %.*s better written as $%.*s",
3530                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3531                     }
3532                 }
3533             }
3534         }
3535         PL_pending_ident = '@';
3536         TERM('@');
3537
3538     case '/':                   /* may either be division or pattern */
3539     case '?':                   /* may either be conditional or pattern */
3540         if (PL_expect != XOPERATOR) {
3541             /* Disable warning on "study /blah/" */
3542             if (PL_oldoldbufptr == PL_last_uni
3543                 && (*PL_last_uni != 's' || s - PL_last_uni < 5
3544                     || memNE(PL_last_uni, "study", 5)
3545                     || isALNUM_lazy_if(PL_last_uni+5,UTF)))
3546                 check_uni();
3547             s = scan_pat(s,OP_MATCH);
3548             TERM(sublex_start());
3549         }
3550         tmp = *s++;
3551         if (tmp == '/')
3552             Mop(OP_DIVIDE);
3553         OPERATOR(tmp);
3554
3555     case '.':
3556         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3557 #ifdef PERL_STRICT_CR
3558             && s[1] == '\n'
3559 #else
3560             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3561 #endif
3562             && (s == PL_linestart || s[-1] == '\n') )
3563         {
3564             PL_lex_formbrack = 0;
3565             PL_expect = XSTATE;
3566             goto rightbracket;
3567         }
3568         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3569             tmp = *s++;
3570             if (*s == tmp) {
3571                 s++;
3572                 if (*s == tmp) {
3573                     s++;
3574                     yylval.ival = OPf_SPECIAL;
3575                 }
3576                 else
3577                     yylval.ival = 0;
3578                 OPERATOR(DOTDOT);
3579             }
3580             if (PL_expect != XOPERATOR)
3581                 check_uni();
3582             Aop(OP_CONCAT);
3583         }
3584         /* FALL THROUGH */
3585     case '0': case '1': case '2': case '3': case '4':
3586     case '5': case '6': case '7': case '8': case '9':
3587         s = scan_num(s, &yylval);
3588         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3589                     "### Saw number in '%s'\n", s);
3590         } );
3591         if (PL_expect == XOPERATOR)
3592             no_op("Number",s);
3593         TERM(THING);
3594
3595     case '\'':
3596         s = scan_str(s,FALSE,FALSE);
3597         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3598                     "### Saw string before '%s'\n", s);
3599         } );
3600         if (PL_expect == XOPERATOR) {
3601             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3602                 PL_expect = XTERM;
3603                 depcom();
3604                 return ',';     /* grandfather non-comma-format format */
3605             }
3606             else
3607                 no_op("String",s);
3608         }
3609         if (!s)
3610             missingterm((char*)0);
3611         yylval.ival = OP_CONST;
3612         TERM(sublex_start());
3613
3614     case '"':
3615         s = scan_str(s,FALSE,FALSE);
3616         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3617                     "### Saw string before '%s'\n", s);
3618         } );
3619         if (PL_expect == XOPERATOR) {
3620             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3621                 PL_expect = XTERM;
3622                 depcom();
3623                 return ',';     /* grandfather non-comma-format format */
3624             }
3625             else
3626                 no_op("String",s);
3627         }
3628         if (!s)
3629             missingterm((char*)0);
3630         yylval.ival = OP_CONST;
3631         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3632             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3633                 yylval.ival = OP_STRINGIFY;
3634                 break;
3635             }
3636         }
3637         TERM(sublex_start());
3638
3639     case '`':
3640         s = scan_str(s,FALSE,FALSE);
3641         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3642                     "### Saw backtick string before '%s'\n", s);
3643         } );
3644         if (PL_expect == XOPERATOR)
3645             no_op("Backticks",s);
3646         if (!s)
3647             missingterm((char*)0);
3648         yylval.ival = OP_BACKTICK;
3649         set_csh();
3650         TERM(sublex_start());
3651
3652     case '\\':
3653         s++;
3654         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3655             Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
3656                         *s, *s);
3657         if (PL_expect == XOPERATOR)
3658             no_op("Backslash",s);
3659         OPERATOR(REFGEN);
3660
3661     case 'v':
3662         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3663             char *start = s;
3664             start++;
3665             start++;
3666             while (isDIGIT(*start) || *start == '_')
3667                 start++;
3668             if (*start == '.' && isDIGIT(start[1])) {
3669                 s = scan_num(s, &yylval);
3670                 TERM(THING);
3671             }
3672             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3673             else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
3674                 char c = *start;
3675                 GV *gv;
3676                 *start = '\0';
3677                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3678                 *start = c;
3679                 if (!gv) {
3680                     s = scan_num(s, &yylval);
3681                     TERM(THING);
3682                 }
3683             }
3684         }
3685         goto keylookup;
3686     case 'x':
3687         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3688             s++;
3689             Mop(OP_REPEAT);
3690         }
3691         goto keylookup;
3692
3693     case '_':
3694     case 'a': case 'A':
3695     case 'b': case 'B':
3696     case 'c': case 'C':
3697     case 'd': case 'D':
3698     case 'e': case 'E':
3699     case 'f': case 'F':
3700     case 'g': case 'G':
3701     case 'h': case 'H':
3702     case 'i': case 'I':
3703     case 'j': case 'J':
3704     case 'k': case 'K':
3705     case 'l': case 'L':
3706     case 'm': case 'M':
3707     case 'n': case 'N':
3708     case 'o': case 'O':
3709     case 'p': case 'P':
3710     case 'q': case 'Q':
3711     case 'r': case 'R':
3712     case 's': case 'S':
3713     case 't': case 'T':
3714     case 'u': case 'U':
3715               case 'V':
3716     case 'w': case 'W':
3717               case 'X':
3718     case 'y': case 'Y':
3719     case 'z': case 'Z':
3720
3721       keylookup: {
3722         gv = Nullgv;
3723         gvp = 0;
3724
3725         PL_bufptr = s;
3726         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3727
3728         /* Some keywords can be followed by any delimiter, including ':' */
3729         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3730                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3731                              (PL_tokenbuf[0] == 'q' &&
3732                               strchr("qwxr", PL_tokenbuf[1])))));
3733
3734         /* x::* is just a word, unless x is "CORE" */
3735         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3736             goto just_a_word;
3737
3738         d = s;
3739         while (d < PL_bufend && isSPACE(*d))
3740                 d++;    /* no comments skipped here, or s### is misparsed */
3741
3742         /* Is this a label? */
3743         if (!tmp && PL_expect == XSTATE
3744               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3745             s = d + 1;
3746             yylval.pval = savepv(PL_tokenbuf);
3747             CLINE;
3748             TOKEN(LABEL);
3749         }
3750
3751         /* Check for keywords */
3752         tmp = keyword(PL_tokenbuf, len);
3753
3754         /* Is this a word before a => operator? */
3755         if (*d == '=' && d[1] == '>') {
3756             CLINE;
3757             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3758             yylval.opval->op_private = OPpCONST_BARE;
3759             if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3760               SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3761             TERM(WORD);
3762         }
3763
3764         if (tmp < 0) {                  /* second-class keyword? */
3765             GV *ogv = Nullgv;   /* override (winner) */
3766             GV *hgv = Nullgv;   /* hidden (loser) */
3767             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3768                 CV *cv;
3769                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3770                     (cv = GvCVu(gv)))
3771                 {
3772                     if (GvIMPORTED_CV(gv))
3773                         ogv = gv;
3774                     else if (! CvMETHOD(cv))
3775                         hgv = gv;
3776                 }
3777                 if (!ogv &&
3778                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3779                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3780                     GvCVu(gv) && GvIMPORTED_CV(gv))
3781                 {
3782                     ogv = gv;
3783                 }
3784             }
3785             if (ogv) {
3786                 tmp = 0;                /* overridden by import or by GLOBAL */
3787             }
3788             else if (gv && !gvp
3789                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3790                      && GvCVu(gv)
3791                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3792             {
3793                 tmp = 0;                /* any sub overrides "weak" keyword */
3794             }
3795             else {                      /* no override */
3796                 tmp = -tmp;
3797                 gv = Nullgv;
3798                 gvp = 0;
3799                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3800                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3801                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3802                         "Ambiguous call resolved as CORE::%s(), %s",
3803                          GvENAME(hgv), "qualify as such or use &");
3804             }
3805         }
3806
3807       reserved_word:
3808         switch (tmp) {
3809
3810         default:                        /* not a keyword */
3811           just_a_word: {
3812                 SV *sv;
3813                 int pkgname = 0;
3814                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3815
3816                 /* Get the rest if it looks like a package qualifier */
3817
3818                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3819                     STRLEN morelen;
3820                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3821                                   TRUE, &morelen);
3822                     if (!morelen)
3823                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3824                                 *s == '\'' ? "'" : "::");
3825                     len += morelen;
3826                     pkgname = 1;
3827                 }
3828
3829                 if (PL_expect == XOPERATOR) {
3830                     if (PL_bufptr == PL_linestart) {
3831                         CopLINE_dec(PL_curcop);
3832                         Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3833                         CopLINE_inc(PL_curcop);
3834                     }
3835                     else
3836                         no_op("Bareword",s);
3837                 }
3838
3839                 /* Look for a subroutine with this name in current package,
3840                    unless name is "Foo::", in which case Foo is a bearword
3841                    (and a package name). */
3842
3843                 if (len > 2 &&
3844                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3845                 {
3846                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3847                         Perl_warner(aTHX_ WARN_BAREWORD,
3848                             "Bareword \"%s\" refers to nonexistent package",
3849                              PL_tokenbuf);
3850                     len -= 2;
3851                     PL_tokenbuf[len] = '\0';
3852                     gv = Nullgv;
3853                     gvp = 0;
3854                 }
3855                 else {
3856                     len = 0;
3857                     if (!gv)
3858                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3859                 }
3860
3861                 /* if we saw a global override before, get the right name */
3862
3863                 if (gvp) {
3864                     sv = newSVpvn("CORE::GLOBAL::",14);
3865                     sv_catpv(sv,PL_tokenbuf);
3866                 }
3867                 else
3868                     sv = newSVpv(PL_tokenbuf,0);
3869
3870                 /* Presume this is going to be a bareword of some sort. */
3871
3872                 CLINE;
3873                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3874                 yylval.opval->op_private = OPpCONST_BARE;
3875
3876                 /* And if "Foo::", then that's what it certainly is. */
3877
3878                 if (len)
3879                     goto safe_bareword;
3880
3881                 /* See if it's the indirect object for a list operator. */
3882
3883                 if (PL_oldoldbufptr &&
3884                     PL_oldoldbufptr < PL_bufptr &&
3885                     (PL_oldoldbufptr == PL_last_lop
3886                      || PL_oldoldbufptr == PL_last_uni) &&
3887                     /* NO SKIPSPACE BEFORE HERE! */
3888                     (PL_expect == XREF ||
3889                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3890                 {
3891                     bool immediate_paren = *s == '(';
3892
3893                     /* (Now we can afford to cross potential line boundary.) */
3894                     s = skipspace(s);
3895
3896                     /* Two barewords in a row may indicate method call. */
3897
3898                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3899                         return tmp;
3900
3901                     /* If not a declared subroutine, it's an indirect object. */
3902                     /* (But it's an indir obj regardless for sort.) */
3903
3904                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
3905                          ((!gv || !GvCVu(gv)) &&
3906                         (PL_last_lop_op != OP_MAPSTART &&
3907                          PL_last_lop_op != OP_GREPSTART))))
3908                     {
3909                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3910                         goto bareword;
3911                     }
3912                 }
3913
3914                 PL_expect = XOPERATOR;
3915                 s = skipspace(s);
3916
3917                 /* Is this a word before a => operator? */
3918                 if (*s == '=' && s[1] == '>' && !pkgname) {
3919                     CLINE;
3920                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
3921                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3922                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3923                     TERM(WORD);
3924                 }
3925
3926                 /* If followed by a paren, it's certainly a subroutine. */
3927                 if (*s == '(') {
3928                     CLINE;
3929                     if (gv && GvCVu(gv)) {
3930                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
3931                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3932                             s = d + 1;
3933                             goto its_constant;
3934                         }
3935                     }
3936                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3937                     PL_expect = XOPERATOR;
3938                     force_next(WORD);
3939                     yylval.ival = 0;
3940                     TOKEN('&');
3941                 }
3942
3943                 /* If followed by var or block, call it a method (unless sub) */
3944
3945                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3946                     PL_last_lop = PL_oldbufptr;
3947                     PL_last_lop_op = OP_METHOD;
3948                     PREBLOCK(METHOD);
3949                 }
3950
3951                 /* If followed by a bareword, see if it looks like indir obj. */
3952
3953                 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
3954                     return tmp;
3955
3956                 /* Not a method, so call it a subroutine (if defined) */
3957
3958                 if (gv && GvCVu(gv)) {
3959                     CV* cv;
3960                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
3961                         Perl_warner(aTHX_ WARN_AMBIGUOUS,
3962                                 "Ambiguous use of -%s resolved as -&%s()",
3963                                 PL_tokenbuf, PL_tokenbuf);
3964                     /* Check for a constant sub */
3965                     cv = GvCV(gv);
3966                     if ((sv = cv_const_sv(cv))) {
3967                   its_constant:
3968                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3969                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3970                         yylval.opval->op_private = 0;
3971                         TOKEN(WORD);
3972                     }
3973
3974                     /* Resolve to GV now. */
3975                     op_free(yylval.opval);
3976                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3977                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3978                     PL_last_lop = PL_oldbufptr;
3979                     PL_last_lop_op = OP_ENTERSUB;
3980                     /* Is there a prototype? */
3981                     if (SvPOK(cv)) {
3982                         STRLEN len;
3983                         char *proto = SvPV((SV*)cv, len);
3984                         if (!len)
3985                             TERM(FUNC0SUB);
3986                         if (strEQ(proto, "$"))
3987                             OPERATOR(UNIOPSUB);
3988                         if (*proto == '&' && *s == '{') {
3989                             sv_setpv(PL_subname,"__ANON__");
3990                             PREBLOCK(LSTOPSUB);
3991                         }
3992                     }
3993                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3994                     PL_expect = XTERM;
3995                     force_next(WORD);
3996                     TOKEN(NOAMP);
3997                 }
3998
3999                 /* Call it a bare word */
4000
4001                 if (PL_hints & HINT_STRICT_SUBS)
4002                     yylval.opval->op_private |= OPpCONST_STRICT;
4003                 else {
4004                 bareword:
4005                     if (ckWARN(WARN_RESERVED)) {
4006                         if (lastchar != '-') {
4007                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4008                             if (!*d && strNE(PL_tokenbuf,"main"))
4009                                 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
4010                                        PL_tokenbuf);
4011                         }
4012                     }
4013                 }
4014
4015             safe_bareword:
4016                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4017                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4018                         "Operator or semicolon missing before %c%s",
4019                         lastchar, PL_tokenbuf);
4020                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
4021                         "Ambiguous use of %c resolved as operator %c",
4022                         lastchar, lastchar);
4023                 }
4024                 TOKEN(WORD);
4025             }
4026
4027         case KEY___FILE__:
4028             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4029                                         newSVpv(CopFILE(PL_curcop),0));
4030             TERM(THING);
4031
4032         case KEY___LINE__:
4033             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4034                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4035             TERM(THING);
4036
4037         case KEY___PACKAGE__:
4038             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4039                                         (PL_curstash
4040                                          ? newSVsv(PL_curstname)
4041                                          : &PL_sv_undef));
4042             TERM(THING);
4043
4044         case KEY___DATA__:
4045         case KEY___END__: {
4046             GV *gv;
4047
4048             /*SUPPRESS 560*/
4049             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4050                 char *pname = "main";
4051                 if (PL_tokenbuf[2] == 'D')
4052                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4053                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4054                 GvMULTI_on(gv);
4055                 if (!GvIO(gv))
4056                     GvIOp(gv) = newIO();
4057                 IoIFP(GvIOp(gv)) = PL_rsfp;
4058 #if defined(HAS_FCNTL) && defined(F_SETFD)
4059                 {
4060                     int fd = PerlIO_fileno(PL_rsfp);
4061                     fcntl(fd,F_SETFD,fd >= 3);
4062                 }
4063 #endif
4064                 /* Mark this internal pseudo-handle as clean */
4065                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4066                 if (PL_preprocess)
4067                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4068                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4069                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4070                 else
4071                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4072 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4073                 /* if the script was opened in binmode, we need to revert
4074                  * it to text mode for compatibility; but only iff it has CRs
4075                  * XXX this is a questionable hack at best. */
4076                 if (PL_bufend-PL_bufptr > 2
4077                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4078                 {
4079                     Off_t loc = 0;
4080                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4081                         loc = PerlIO_tell(PL_rsfp);
4082                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
4083                     }
4084 #ifdef NETWARE
4085                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4086 #else
4087                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4088 #endif  /* NETWARE */
4089 #ifdef PERLIO_IS_STDIO /* really? */
4090 #  if defined(__BORLANDC__)
4091                         /* XXX see note in do_binmode() */
4092                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4093 #  endif
4094 #endif
4095                         if (loc > 0)
4096                             PerlIO_seek(PL_rsfp, loc, 0);
4097                     }
4098                 }
4099 #endif
4100 #ifdef PERLIO_LAYERS
4101                 if (UTF && !IN_BYTES)
4102                     PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4103 #endif
4104                 PL_rsfp = Nullfp;
4105             }
4106             goto fake_eof;
4107         }
4108
4109         case KEY_AUTOLOAD:
4110         case KEY_DESTROY:
4111         case KEY_BEGIN:
4112         case KEY_CHECK:
4113         case KEY_INIT:
4114         case KEY_END:
4115             if (PL_expect == XSTATE) {
4116                 s = PL_bufptr;
4117                 goto really_sub;
4118             }
4119             goto just_a_word;
4120
4121         case KEY_CORE:
4122             if (*s == ':' && s[1] == ':') {
4123                 s += 2;
4124                 d = s;
4125                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4126                 if (!(tmp = keyword(PL_tokenbuf, len)))
4127                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4128                 if (tmp < 0)
4129                     tmp = -tmp;
4130                 goto reserved_word;
4131             }
4132             goto just_a_word;
4133
4134         case KEY_abs:
4135             UNI(OP_ABS);
4136
4137         case KEY_alarm:
4138             UNI(OP_ALARM);
4139
4140         case KEY_accept:
4141             LOP(OP_ACCEPT,XTERM);
4142
4143         case KEY_and:
4144             OPERATOR(ANDOP);
4145
4146         case KEY_atan2:
4147             LOP(OP_ATAN2,XTERM);
4148
4149         case KEY_bind:
4150             LOP(OP_BIND,XTERM);
4151
4152         case KEY_binmode:
4153             LOP(OP_BINMODE,XTERM);
4154
4155         case KEY_bless:
4156             LOP(OP_BLESS,XTERM);
4157
4158         case KEY_chop:
4159             UNI(OP_CHOP);
4160
4161         case KEY_continue:
4162             PREBLOCK(CONTINUE);
4163
4164         case KEY_chdir:
4165             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
4166             UNI(OP_CHDIR);
4167
4168         case KEY_close:
4169             UNI(OP_CLOSE);
4170
4171         case KEY_closedir:
4172             UNI(OP_CLOSEDIR);
4173
4174         case KEY_cmp:
4175             Eop(OP_SCMP);
4176
4177         case KEY_caller:
4178             UNI(OP_CALLER);
4179
4180         case KEY_crypt:
4181 #ifdef FCRYPT
4182             if (!PL_cryptseen) {
4183                 PL_cryptseen = TRUE;
4184                 init_des();
4185             }
4186 #endif
4187             LOP(OP_CRYPT,XTERM);
4188
4189         case KEY_chmod:
4190             LOP(OP_CHMOD,XTERM);
4191
4192         case KEY_chown:
4193             LOP(OP_CHOWN,XTERM);
4194
4195         case KEY_connect:
4196             LOP(OP_CONNECT,XTERM);
4197
4198         case KEY_chr:
4199             UNI(OP_CHR);
4200
4201         case KEY_cos:
4202             UNI(OP_COS);
4203
4204         case KEY_chroot:
4205             UNI(OP_CHROOT);
4206
4207         case KEY_do:
4208             s = skipspace(s);
4209             if (*s == '{')
4210                 PRETERMBLOCK(DO);
4211             if (*s != '\'')
4212                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4213             OPERATOR(DO);
4214
4215         case KEY_die:
4216             PL_hints |= HINT_BLOCK_SCOPE;
4217             LOP(OP_DIE,XTERM);
4218
4219         case KEY_defined:
4220             UNI(OP_DEFINED);
4221
4222         case KEY_delete:
4223             UNI(OP_DELETE);
4224
4225         case KEY_dbmopen:
4226             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4227             LOP(OP_DBMOPEN,XTERM);
4228
4229         case KEY_dbmclose:
4230             UNI(OP_DBMCLOSE);
4231
4232         case KEY_dump:
4233             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4234             LOOPX(OP_DUMP);
4235
4236         case KEY_else:
4237             PREBLOCK(ELSE);
4238
4239         case KEY_elsif:
4240             yylval.ival = CopLINE(PL_curcop);
4241             OPERATOR(ELSIF);
4242
4243         case KEY_eq:
4244             Eop(OP_SEQ);
4245
4246         case KEY_exists:
4247             UNI(OP_EXISTS);
4248         
4249         case KEY_exit:
4250             UNI(OP_EXIT);
4251
4252         case KEY_eval:
4253             s = skipspace(s);
4254             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4255             UNIBRACK(OP_ENTEREVAL);
4256
4257         case KEY_eof:
4258             UNI(OP_EOF);
4259
4260         case KEY_exp:
4261             UNI(OP_EXP);
4262
4263         case KEY_each:
4264             UNI(OP_EACH);
4265
4266         case KEY_exec:
4267             set_csh();
4268             LOP(OP_EXEC,XREF);
4269
4270         case KEY_endhostent:
4271             FUN0(OP_EHOSTENT);
4272
4273         case KEY_endnetent:
4274             FUN0(OP_ENETENT);
4275
4276         case KEY_endservent:
4277             FUN0(OP_ESERVENT);
4278
4279         case KEY_endprotoent:
4280             FUN0(OP_EPROTOENT);
4281
4282         case KEY_endpwent:
4283             FUN0(OP_EPWENT);
4284
4285         case KEY_endgrent:
4286             FUN0(OP_EGRENT);
4287
4288         case KEY_for:
4289         case KEY_foreach:
4290             yylval.ival = CopLINE(PL_curcop);
4291             s = skipspace(s);
4292             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4293                 char *p = s;
4294                 if ((PL_bufend - p) >= 3 &&
4295                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4296                     p += 2;
4297                 else if ((PL_bufend - p) >= 4 &&
4298                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4299                     p += 3;
4300                 p = skipspace(p);
4301                 if (isIDFIRST_lazy_if(p,UTF)) {
4302                     p = scan_ident(p, PL_bufend,
4303                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4304                     p = skipspace(p);
4305                 }
4306                 if (*p != '$')
4307                     Perl_croak(aTHX_ "Missing $ on loop variable");
4308             }
4309             OPERATOR(FOR);
4310
4311         case KEY_formline:
4312             LOP(OP_FORMLINE,XTERM);
4313
4314         case KEY_fork:
4315             FUN0(OP_FORK);
4316
4317         case KEY_fcntl:
4318             LOP(OP_FCNTL,XTERM);
4319
4320         case KEY_fileno:
4321             UNI(OP_FILENO);
4322
4323         case KEY_flock:
4324             LOP(OP_FLOCK,XTERM);
4325
4326         case KEY_gt:
4327             Rop(OP_SGT);
4328
4329         case KEY_ge:
4330             Rop(OP_SGE);
4331
4332         case KEY_grep:
4333             LOP(OP_GREPSTART, XREF);
4334
4335         case KEY_goto:
4336             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4337             LOOPX(OP_GOTO);
4338
4339         case KEY_gmtime:
4340             UNI(OP_GMTIME);
4341
4342         case KEY_getc:
4343             UNI(OP_GETC);
4344
4345         case KEY_getppid:
4346             FUN0(OP_GETPPID);
4347
4348         case KEY_getpgrp:
4349             UNI(OP_GETPGRP);
4350
4351         case KEY_getpriority:
4352             LOP(OP_GETPRIORITY,XTERM);
4353
4354         case KEY_getprotobyname:
4355             UNI(OP_GPBYNAME);
4356
4357         case KEY_getprotobynumber:
4358             LOP(OP_GPBYNUMBER,XTERM);
4359
4360         case KEY_getprotoent:
4361             FUN0(OP_GPROTOENT);
4362
4363         case KEY_getpwent:
4364             FUN0(OP_GPWENT);
4365
4366         case KEY_getpwnam:
4367             UNI(OP_GPWNAM);
4368
4369