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