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