Integrate mainline.
[p5sagit/p5-mst-13.2.git] / toke.c
1 /*    toke.c
2  *
3  *    Copyright (c) 1991-2002, Larry Wall
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  *
8  */
9
10 /*
11  *   "It all comes from here, the stench and the peril."  --Frodo
12  */
13
14 /*
15  * This file is the lexer for Perl.  It's closely linked to the
16  * parser, perly.y.
17  *
18  * The main routine is yylex(), which returns the next token.
19  */
20
21 #include "EXTERN.h"
22 #define PERL_IN_TOKE_C
23 #include "perl.h"
24
25 #define yychar  PL_yychar
26 #define yylval  PL_yylval
27
28 static char ident_too_long[] = "Identifier too long";
29 static char c_without_g[] = "Use of /c modifier is meaningless without /g";
30 static char c_in_subst[] = "Use of /c modifier is meaningless in s///";
31
32 static void restore_rsfp(pTHX_ void *f);
33 #ifndef PERL_NO_UTF16_FILTER
34 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
35 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
36 #endif
37
38 #define XFAKEBRACK 128
39 #define XENUMMASK 127
40
41 #ifdef USE_UTF8_SCRIPTS
42 #   define UTF (!IN_BYTES)
43 #else
44 #   define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
45 #endif
46
47 /* In variables named $^X, these are the legal values for X.
48  * 1999-02-27 mjd-perl-patch@plover.com */
49 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
50
51 /* On MacOS, respect nonbreaking spaces */
52 #ifdef MACOS_TRADITIONAL
53 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
54 #else
55 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
56 #endif
57
58 /* LEX_* are values for PL_lex_state, the state of the lexer.
59  * They are arranged oddly so that the guard on the switch statement
60  * can get by with a single comparison (if the compiler is smart enough).
61  */
62
63 /* #define LEX_NOTPARSING               11 is done in perl.h. */
64
65 #define LEX_NORMAL              10
66 #define LEX_INTERPNORMAL         9
67 #define LEX_INTERPCASEMOD        8
68 #define LEX_INTERPPUSH           7
69 #define LEX_INTERPSTART          6
70 #define LEX_INTERPEND            5
71 #define LEX_INTERPENDMAYBE       4
72 #define LEX_INTERPCONCAT         3
73 #define LEX_INTERPCONST          2
74 #define LEX_FORMLINE             1
75 #define LEX_KNOWNEXT             0
76
77 #ifdef ff_next
78 #undef ff_next
79 #endif
80
81 #ifdef USE_PURE_BISON
82 #  ifndef YYMAXLEVEL
83 #    define YYMAXLEVEL 100
84 #  endif
85 YYSTYPE* yylval_pointer[YYMAXLEVEL];
86 int* yychar_pointer[YYMAXLEVEL];
87 int yyactlevel = -1;
88 #  undef yylval
89 #  undef yychar
90 #  define yylval (*yylval_pointer[yyactlevel])
91 #  define yychar (*yychar_pointer[yyactlevel])
92 #  define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
93 #  undef yylex
94 #  define yylex()      Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
95 #endif
96
97 #include "keywords.h"
98
99 /* CLINE is a macro that ensures PL_copline has a sane value */
100
101 #ifdef CLINE
102 #undef CLINE
103 #endif
104 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
105
106 /*
107  * Convenience functions to return different tokens and prime the
108  * lexer for the next token.  They all take an argument.
109  *
110  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
111  * OPERATOR     : generic operator
112  * AOPERATOR    : assignment operator
113  * PREBLOCK     : beginning the block after an if, while, foreach, ...
114  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
115  * PREREF       : *EXPR where EXPR is not a simple identifier
116  * TERM         : expression term
117  * LOOPX        : loop exiting command (goto, last, dump, etc)
118  * FTST         : file test operator
119  * FUN0         : zero-argument function
120  * FUN1         : not used, except for not, which isn't a UNIOP
121  * BOop         : bitwise or or xor
122  * BAop         : bitwise and
123  * SHop         : shift operator
124  * PWop         : power operator
125  * PMop         : pattern-matching operator
126  * Aop          : addition-level operator
127  * Mop          : multiplication-level operator
128  * Eop          : equality-testing operator
129  * Rop          : relational operator <= != gt
130  *
131  * Also see LOP and lop() below.
132  */
133
134 /* Note that REPORT() and REPORT2() will be expressions that supply
135  * their own trailing comma, not suitable for statements as such. */
136 #ifdef DEBUGGING /* Serve -DT. */
137 #   define REPORT(x,retval) tokereport(x,s,(int)retval),
138 #   define REPORT2(x,retval) tokereport(x,s, yylval.ival),
139 #else
140 #   define REPORT(x,retval)
141 #   define REPORT2(x,retval)
142 #endif
143
144 #define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
145 #define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
146 #define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
147 #define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
148 #define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
149 #define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
150 #define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
151 #define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
152 #define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
153 #define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
154 #define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
155 #define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
156 #define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
157 #define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
158 #define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
159 #define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
160 #define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
161 #define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
162 #define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
163 #define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
164
165 /* This bit of chicanery makes a unary function followed by
166  * a parenthesis into a function with one argument, highest precedence.
167  */
168 #define UNI(f) return(yylval.ival = f, \
169         REPORT("uni",f) \
170         PL_expect = XTERM, \
171         PL_bufptr = s, \
172         PL_last_uni = PL_oldbufptr, \
173         PL_last_lop_op = f, \
174         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
175
176 #define UNIBRACK(f) return(yylval.ival = f, \
177         REPORT("uni",f) \
178         PL_bufptr = s, \
179         PL_last_uni = PL_oldbufptr, \
180         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
181
182 /* grandfather return to old style */
183 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
184
185 #ifdef DEBUGGING
186
187 STATIC void
188 S_tokereport(pTHX_ char *thing, char* s, I32 rv)
189 {
190     DEBUG_T({
191         SV* report = newSVpv(thing, 0);
192         Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
193                 (IV)rv);
194
195         if (s - PL_bufptr > 0)
196             sv_catpvn(report, PL_bufptr, s - PL_bufptr);
197         else {
198             if (PL_oldbufptr && *PL_oldbufptr)
199                 sv_catpv(report, PL_tokenbuf);
200         }
201         PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
202     });
203 }
204
205 #endif
206
207 /*
208  * S_ao
209  *
210  * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
211  * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
212  */
213
214 STATIC int
215 S_ao(pTHX_ int toketype)
216 {
217     if (*PL_bufptr == '=') {
218         PL_bufptr++;
219         if (toketype == ANDAND)
220             yylval.ival = OP_ANDASSIGN;
221         else if (toketype == OROR)
222             yylval.ival = OP_ORASSIGN;
223         else if (toketype == DORDOR)
224             yylval.ival = OP_DORASSIGN;
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 = (char)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 = (OPCODE)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, (line_t)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++ = (char)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-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1498                                     *dst-- = (U8)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                     if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1542                         /* \N{U+...} */
1543                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1544                           PERL_SCAN_DISALLOW_PREFIX;
1545                         s += 3;
1546                         len = e - s;
1547                         uv = grok_hex(s, &len, &flags, NULL);
1548                         s = e + 1;
1549                         goto NUM_ESCAPE_INSERT;
1550                     }
1551                     res = newSVpvn(s + 1, e - s - 1);
1552                     res = new_constant( Nullch, 0, "charnames",
1553                                         res, Nullsv, "\\N{...}" );
1554                     if (has_utf8)
1555                         sv_utf8_upgrade(res);
1556                     str = SvPV(res,len);
1557 #ifdef EBCDIC_NEVER_MIND
1558                     /* charnames uses pack U and that has been
1559                      * recently changed to do the below uni->native
1560                      * mapping, so this would be redundant (and wrong,
1561                      * the code point would be doubly converted).
1562                      * But leave this in just in case the pack U change
1563                      * gets revoked, but the semantics is still
1564                      * desireable for charnames. --jhi */
1565                     {
1566                          UV uv = utf8_to_uvchr((U8*)str, 0);
1567
1568                          if (uv < 0x100) {
1569                               U8 tmpbuf[UTF8_MAXLEN+1], *d;
1570
1571                               d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1572                               sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1573                               str = SvPV(res, len);
1574                          }
1575                     }
1576 #endif
1577                     if (!has_utf8 && SvUTF8(res)) {
1578                         char *ostart = SvPVX(sv);
1579                         SvCUR_set(sv, d - ostart);
1580                         SvPOK_on(sv);
1581                         *d = '\0';
1582                         sv_utf8_upgrade(sv);
1583                         /* this just broke our allocation above... */
1584                         SvGROW(sv, (STRLEN)(send - start));
1585                         d = SvPVX(sv) + SvCUR(sv);
1586                         has_utf8 = TRUE;
1587                     }
1588                     if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1589                         char *odest = SvPVX(sv);
1590
1591                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1592                         d = SvPVX(sv) + (d - odest);
1593                     }
1594                     Copy(str, d, len, char);
1595                     d += len;
1596                     SvREFCNT_dec(res);
1597                   cont_scan:
1598                     s = e + 1;
1599                 }
1600                 else
1601                     yyerror("Missing braces on \\N{}");
1602                 continue;
1603
1604             /* \c is a control character */
1605             case 'c':
1606                 s++;
1607                 {
1608                     U8 c = *s++;
1609 #ifdef EBCDIC
1610                     if (isLOWER(c))
1611                         c = toUPPER(c);
1612 #endif
1613                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1614                 }
1615                 continue;
1616
1617             /* printf-style backslashes, formfeeds, newlines, etc */
1618             case 'b':
1619                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1620                 break;
1621             case 'n':
1622                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1623                 break;
1624             case 'r':
1625                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1626                 break;
1627             case 'f':
1628                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1629                 break;
1630             case 't':
1631                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1632                 break;
1633             case 'e':
1634                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1635                 break;
1636             case 'a':
1637                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1638                 break;
1639             } /* end switch */
1640
1641             s++;
1642             continue;
1643         } /* end if (backslash) */
1644
1645     default_action:
1646         /* If we started with encoded form, or already know we want it
1647            and then encode the next character */
1648         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1649             STRLEN len  = 1;
1650             UV uv       = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1651             STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1652             s += len;
1653             if (need > len) {
1654                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1655                 STRLEN off = d - SvPVX(sv);
1656                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1657             }
1658             d = (char*)uvchr_to_utf8((U8*)d, uv);
1659             has_utf8 = TRUE;
1660         }
1661         else {
1662             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1663         }
1664     } /* while loop to process each character */
1665
1666     /* terminate the string and set up the sv */
1667     *d = '\0';
1668     SvCUR_set(sv, d - SvPVX(sv));
1669     if (SvCUR(sv) >= SvLEN(sv))
1670       Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1671
1672     SvPOK_on(sv);
1673     if (PL_encoding && !has_utf8) {
1674         sv_recode_to_utf8(sv, PL_encoding);
1675         has_utf8 = TRUE;
1676     }
1677     if (has_utf8) {
1678         SvUTF8_on(sv);
1679         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1680                 PL_sublex_info.sub_op->op_private |=
1681                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1682         }
1683     }
1684
1685     /* shrink the sv if we allocated more than we used */
1686     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1687         SvLEN_set(sv, SvCUR(sv) + 1);
1688         Renew(SvPVX(sv), SvLEN(sv), char);
1689     }
1690
1691     /* return the substring (via yylval) only if we parsed anything */
1692     if (s > PL_bufptr) {
1693         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1694             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1695                               sv, Nullsv,
1696                               ( PL_lex_inwhat == OP_TRANS
1697                                 ? "tr"
1698                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1699                                     ? "s"
1700                                     : "qq")));
1701         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1702     } else
1703         SvREFCNT_dec(sv);
1704     return s;
1705 }
1706
1707 /* S_intuit_more
1708  * Returns TRUE if there's more to the expression (e.g., a subscript),
1709  * FALSE otherwise.
1710  *
1711  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1712  *
1713  * ->[ and ->{ return TRUE
1714  * { and [ outside a pattern are always subscripts, so return TRUE
1715  * if we're outside a pattern and it's not { or [, then return FALSE
1716  * if we're in a pattern and the first char is a {
1717  *   {4,5} (any digits around the comma) returns FALSE
1718  * if we're in a pattern and the first char is a [
1719  *   [] returns FALSE
1720  *   [SOMETHING] has a funky algorithm to decide whether it's a
1721  *      character class or not.  It has to deal with things like
1722  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1723  * anything else returns TRUE
1724  */
1725
1726 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1727
1728 STATIC int
1729 S_intuit_more(pTHX_ register char *s)
1730 {
1731     if (PL_lex_brackets)
1732         return TRUE;
1733     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1734         return TRUE;
1735     if (*s != '{' && *s != '[')
1736         return FALSE;
1737     if (!PL_lex_inpat)
1738         return TRUE;
1739
1740     /* In a pattern, so maybe we have {n,m}. */
1741     if (*s == '{') {
1742         s++;
1743         if (!isDIGIT(*s))
1744             return TRUE;
1745         while (isDIGIT(*s))
1746             s++;
1747         if (*s == ',')
1748             s++;
1749         while (isDIGIT(*s))
1750             s++;
1751         if (*s == '}')
1752             return FALSE;
1753         return TRUE;
1754         
1755     }
1756
1757     /* On the other hand, maybe we have a character class */
1758
1759     s++;
1760     if (*s == ']' || *s == '^')
1761         return FALSE;
1762     else {
1763         /* this is terrifying, and it works */
1764         int weight = 2;         /* let's weigh the evidence */
1765         char seen[256];
1766         unsigned char un_char = 255, last_un_char;
1767         char *send = strchr(s,']');
1768         char tmpbuf[sizeof PL_tokenbuf * 4];
1769
1770         if (!send)              /* has to be an expression */
1771             return TRUE;
1772
1773         Zero(seen,256,char);
1774         if (*s == '$')
1775             weight -= 3;
1776         else if (isDIGIT(*s)) {
1777             if (s[1] != ']') {
1778                 if (isDIGIT(s[1]) && s[2] == ']')
1779                     weight -= 10;
1780             }
1781             else
1782                 weight -= 100;
1783         }
1784         for (; s < send; s++) {
1785             last_un_char = un_char;
1786             un_char = (unsigned char)*s;
1787             switch (*s) {
1788             case '@':
1789             case '&':
1790             case '$':
1791                 weight -= seen[un_char] * 10;
1792                 if (isALNUM_lazy_if(s+1,UTF)) {
1793                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1794                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1795                         weight -= 100;
1796                     else
1797                         weight -= 10;
1798                 }
1799                 else if (*s == '$' && s[1] &&
1800                   strchr("[#!%*<>()-=",s[1])) {
1801                     if (/*{*/ strchr("])} =",s[2]))
1802                         weight -= 10;
1803                     else
1804                         weight -= 1;
1805                 }
1806                 break;
1807             case '\\':
1808                 un_char = 254;
1809                 if (s[1]) {
1810                     if (strchr("wds]",s[1]))
1811                         weight += 100;
1812                     else if (seen['\''] || seen['"'])
1813                         weight += 1;
1814                     else if (strchr("rnftbxcav",s[1]))
1815                         weight += 40;
1816                     else if (isDIGIT(s[1])) {
1817                         weight += 40;
1818                         while (s[1] && isDIGIT(s[1]))
1819                             s++;
1820                     }
1821                 }
1822                 else
1823                     weight += 100;
1824                 break;
1825             case '-':
1826                 if (s[1] == '\\')
1827                     weight += 50;
1828                 if (strchr("aA01! ",last_un_char))
1829                     weight += 30;
1830                 if (strchr("zZ79~",s[1]))
1831                     weight += 30;
1832                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1833                     weight -= 5;        /* cope with negative subscript */
1834                 break;
1835             default:
1836                 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1837                         isALPHA(*s) && s[1] && isALPHA(s[1])) {
1838                     char *d = tmpbuf;
1839                     while (isALPHA(*s))
1840                         *d++ = *s++;
1841                     *d = '\0';
1842                     if (keyword(tmpbuf, d - tmpbuf))
1843                         weight -= 150;
1844                 }
1845                 if (un_char == last_un_char + 1)
1846                     weight += 5;
1847                 weight -= seen[un_char];
1848                 break;
1849             }
1850             seen[un_char]++;
1851         }
1852         if (weight >= 0)        /* probably a character class */
1853             return FALSE;
1854     }
1855
1856     return TRUE;
1857 }
1858
1859 /*
1860  * S_intuit_method
1861  *
1862  * Does all the checking to disambiguate
1863  *   foo bar
1864  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
1865  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1866  *
1867  * First argument is the stuff after the first token, e.g. "bar".
1868  *
1869  * Not a method if bar is a filehandle.
1870  * Not a method if foo is a subroutine prototyped to take a filehandle.
1871  * Not a method if it's really "Foo $bar"
1872  * Method if it's "foo $bar"
1873  * Not a method if it's really "print foo $bar"
1874  * Method if it's really "foo package::" (interpreted as package->foo)
1875  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
1876  * Not a method if bar is a filehandle or package, but is quoted with
1877  *   =>
1878  */
1879
1880 STATIC int
1881 S_intuit_method(pTHX_ char *start, GV *gv)
1882 {
1883     char *s = start + (*start == '$');
1884     char tmpbuf[sizeof PL_tokenbuf];
1885     STRLEN len;
1886     GV* indirgv;
1887
1888     if (gv) {
1889         CV *cv;
1890         if (GvIO(gv))
1891             return 0;
1892         if ((cv = GvCVu(gv))) {
1893             char *proto = SvPVX(cv);
1894             if (proto) {
1895                 if (*proto == ';')
1896                     proto++;
1897                 if (*proto == '*')
1898                     return 0;
1899             }
1900         } else
1901             gv = 0;
1902     }
1903     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1904     /* start is the beginning of the possible filehandle/object,
1905      * and s is the end of it
1906      * tmpbuf is a copy of it
1907      */
1908
1909     if (*start == '$') {
1910         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1911             return 0;
1912         s = skipspace(s);
1913         PL_bufptr = start;
1914         PL_expect = XREF;
1915         return *s == '(' ? FUNCMETH : METHOD;
1916     }
1917     if (!keyword(tmpbuf, len)) {
1918         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1919             len -= 2;
1920             tmpbuf[len] = '\0';
1921             goto bare_package;
1922         }
1923         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1924         if (indirgv && GvCVu(indirgv))
1925             return 0;
1926         /* filehandle or package name makes it a method */
1927         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1928             s = skipspace(s);
1929             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1930                 return 0;       /* no assumptions -- "=>" quotes bearword */
1931       bare_package:
1932             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1933                                                    newSVpvn(tmpbuf,len));
1934             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1935             PL_expect = XTERM;
1936             force_next(WORD);
1937             PL_bufptr = s;
1938             return *s == '(' ? FUNCMETH : METHOD;
1939         }
1940     }
1941     return 0;
1942 }
1943
1944 /*
1945  * S_incl_perldb
1946  * Return a string of Perl code to load the debugger.  If PERL5DB
1947  * is set, it will return the contents of that, otherwise a
1948  * compile-time require of perl5db.pl.
1949  */
1950
1951 STATIC char*
1952 S_incl_perldb(pTHX)
1953 {
1954     if (PL_perldb) {
1955         char *pdb = PerlEnv_getenv("PERL5DB");
1956
1957         if (pdb)
1958             return pdb;
1959         SETERRNO(0,SS$_NORMAL);
1960         return "BEGIN { require 'perl5db.pl' }";
1961     }
1962     return "";
1963 }
1964
1965
1966 /* Encoded script support. filter_add() effectively inserts a
1967  * 'pre-processing' function into the current source input stream.
1968  * Note that the filter function only applies to the current source file
1969  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1970  *
1971  * The datasv parameter (which may be NULL) can be used to pass
1972  * private data to this instance of the filter. The filter function
1973  * can recover the SV using the FILTER_DATA macro and use it to
1974  * store private buffers and state information.
1975  *
1976  * The supplied datasv parameter is upgraded to a PVIO type
1977  * and the IoDIRP/IoANY field is used to store the function pointer,
1978  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1979  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1980  * private use must be set using malloc'd pointers.
1981  */
1982
1983 SV *
1984 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1985 {
1986     if (!funcp)
1987         return Nullsv;
1988
1989     if (!PL_rsfp_filters)
1990         PL_rsfp_filters = newAV();
1991     if (!datasv)
1992         datasv = NEWSV(255,0);
1993     if (!SvUPGRADE(datasv, SVt_PVIO))
1994         Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1995     IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
1996     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
1997     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
1998                           (void*)funcp, SvPV_nolen(datasv)));
1999     av_unshift(PL_rsfp_filters, 1);
2000     av_store(PL_rsfp_filters, 0, datasv) ;
2001     return(datasv);
2002 }
2003
2004
2005 /* Delete most recently added instance of this filter function. */
2006 void
2007 Perl_filter_del(pTHX_ filter_t funcp)
2008 {
2009     SV *datasv;
2010     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
2011     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2012         return;
2013     /* if filter is on top of stack (usual case) just pop it off */
2014     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2015     if (IoANY(datasv) == (void *)funcp) {
2016         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2017         IoANY(datasv) = (void *)NULL;
2018         sv_free(av_pop(PL_rsfp_filters));
2019
2020         return;
2021     }
2022     /* we need to search for the correct entry and clear it     */
2023     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2024 }
2025
2026
2027 /* Invoke the n'th filter function for the current rsfp.         */
2028 I32
2029 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2030
2031
2032                         /* 0 = read one text line */
2033 {
2034     filter_t funcp;
2035     SV *datasv = NULL;
2036
2037     if (!PL_rsfp_filters)
2038         return -1;
2039     if (idx > AvFILLp(PL_rsfp_filters)){       /* Any more filters?     */
2040         /* Provide a default input filter to make life easy.    */
2041         /* Note that we append to the line. This is handy.      */
2042         DEBUG_P(PerlIO_printf(Perl_debug_log,
2043                               "filter_read %d: from rsfp\n", idx));
2044         if (maxlen) {
2045             /* Want a block */
2046             int len ;
2047             int old_len = SvCUR(buf_sv) ;
2048
2049             /* ensure buf_sv is large enough */
2050             SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2051             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2052                 if (PerlIO_error(PL_rsfp))
2053                     return -1;          /* error */
2054                 else
2055                     return 0 ;          /* end of file */
2056             }
2057             SvCUR_set(buf_sv, old_len + len) ;
2058         } else {
2059             /* Want a line */
2060             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2061                 if (PerlIO_error(PL_rsfp))
2062                     return -1;          /* error */
2063                 else
2064                     return 0 ;          /* end of file */
2065             }
2066         }
2067         return SvCUR(buf_sv);
2068     }
2069     /* Skip this filter slot if filter has been deleted */
2070     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2071         DEBUG_P(PerlIO_printf(Perl_debug_log,
2072                               "filter_read %d: skipped (filter deleted)\n",
2073                               idx));
2074         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2075     }
2076     /* Get function pointer hidden within datasv        */
2077     funcp = (filter_t)IoANY(datasv);
2078     DEBUG_P(PerlIO_printf(Perl_debug_log,
2079                           "filter_read %d: via function %p (%s)\n",
2080                           idx, (void*)funcp, SvPV_nolen(datasv)));
2081     /* Call function. The function is expected to       */
2082     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2083     /* Return: <0:error, =0:eof, >0:not eof             */
2084     return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2085 }
2086
2087 STATIC char *
2088 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2089 {
2090 #ifdef PERL_CR_FILTER
2091     if (!PL_rsfp_filters) {
2092         filter_add(S_cr_textfilter,NULL);
2093     }
2094 #endif
2095     if (PL_rsfp_filters) {
2096
2097         if (!append)
2098             SvCUR_set(sv, 0);   /* start with empty line        */
2099         if (FILTER_READ(0, sv, 0) > 0)
2100             return ( SvPVX(sv) ) ;
2101         else
2102             return Nullch ;
2103     }
2104     else
2105         return (sv_gets(sv, fp, append));
2106 }
2107
2108 STATIC HV *
2109 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2110 {
2111     GV *gv;
2112
2113     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2114         return PL_curstash;
2115
2116     if (len > 2 &&
2117         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2118         (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2119     {
2120         return GvHV(gv);                        /* Foo:: */
2121     }
2122
2123     /* use constant CLASS => 'MyClass' */
2124     if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2125         SV *sv;
2126         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2127             pkgname = SvPV_nolen(sv);
2128         }
2129     }
2130
2131     return gv_stashpv(pkgname, FALSE);
2132 }
2133
2134 #ifdef DEBUGGING
2135     static char* exp_name[] =
2136         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2137           "ATTRTERM", "TERMBLOCK"
2138         };
2139 #endif
2140
2141 /*
2142   yylex
2143
2144   Works out what to call the token just pulled out of the input
2145   stream.  The yacc parser takes care of taking the ops we return and
2146   stitching them into a tree.
2147
2148   Returns:
2149     PRIVATEREF
2150
2151   Structure:
2152       if read an identifier
2153           if we're in a my declaration
2154               croak if they tried to say my($foo::bar)
2155               build the ops for a my() declaration
2156           if it's an access to a my() variable
2157               are we in a sort block?
2158                   croak if my($a); $a <=> $b
2159               build ops for access to a my() variable
2160           if in a dq string, and they've said @foo and we can't find @foo
2161               croak
2162           build ops for a bareword
2163       if we already built the token before, use it.
2164 */
2165
2166 #ifdef USE_PURE_BISON
2167 int
2168 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2169 {
2170     int r;
2171
2172     yyactlevel++;
2173     yylval_pointer[yyactlevel] = lvalp;
2174     yychar_pointer[yyactlevel] = lcharp;
2175     if (yyactlevel >= YYMAXLEVEL)
2176         Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2177
2178     r = Perl_yylex(aTHX);
2179
2180     if (yyactlevel > 0)
2181        yyactlevel--;
2182
2183     return r;
2184 }
2185 #endif
2186
2187 #ifdef __SC__
2188 #pragma segment Perl_yylex
2189 #endif
2190 int
2191 Perl_yylex(pTHX)
2192 {
2193     register char *s;
2194     register char *d;
2195     register I32 tmp;
2196     STRLEN len;
2197     GV *gv = Nullgv;
2198     GV **gvp = 0;
2199     bool bof = FALSE;
2200
2201     /* check if there's an identifier for us to look at */
2202     if (PL_pending_ident)
2203         return S_pending_ident(aTHX);
2204
2205     /* no identifier pending identification */
2206
2207     switch (PL_lex_state) {
2208 #ifdef COMMENTARY
2209     case LEX_NORMAL:            /* Some compilers will produce faster */
2210     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2211         break;
2212 #endif
2213
2214     /* when we've already built the next token, just pull it out of the queue */
2215     case LEX_KNOWNEXT:
2216         PL_nexttoke--;
2217         yylval = PL_nextval[PL_nexttoke];
2218         if (!PL_nexttoke) {
2219             PL_lex_state = PL_lex_defer;
2220             PL_expect = PL_lex_expect;
2221             PL_lex_defer = LEX_NORMAL;
2222         }
2223         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2224               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2225               (IV)PL_nexttype[PL_nexttoke]); });
2226
2227         return(PL_nexttype[PL_nexttoke]);
2228
2229     /* interpolated case modifiers like \L \U, including \Q and \E.
2230        when we get here, PL_bufptr is at the \
2231     */
2232     case LEX_INTERPCASEMOD:
2233 #ifdef DEBUGGING
2234         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2235             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2236 #endif
2237         /* handle \E or end of string */
2238         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2239             char oldmod;
2240
2241             /* if at a \E */
2242             if (PL_lex_casemods) {
2243                 oldmod = PL_lex_casestack[--PL_lex_casemods];
2244                 PL_lex_casestack[PL_lex_casemods] = '\0';
2245
2246                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2247                     PL_bufptr += 2;
2248                     PL_lex_state = LEX_INTERPCONCAT;
2249                 }
2250                 return ')';
2251             }
2252             if (PL_bufptr != PL_bufend)
2253                 PL_bufptr += 2;
2254             PL_lex_state = LEX_INTERPCONCAT;
2255             return yylex();
2256         }
2257         else {
2258             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2259               "### Saw case modifier at '%s'\n", PL_bufptr); });
2260             s = PL_bufptr + 1;
2261             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2262                 tmp = *s, *s = s[2], s[2] = (char)tmp;  /* misordered... */
2263             if (strchr("LU", *s) &&
2264                 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
2265             {
2266                 PL_lex_casestack[--PL_lex_casemods] = '\0';
2267                 return ')';
2268             }
2269             if (PL_lex_casemods > 10) {
2270                 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2271                 if (newlb != PL_lex_casestack) {
2272                     SAVEFREEPV(newlb);
2273                     PL_lex_casestack = newlb;
2274                 }
2275             }
2276             PL_lex_casestack[PL_lex_casemods++] = *s;
2277             PL_lex_casestack[PL_lex_casemods] = '\0';
2278             PL_lex_state = LEX_INTERPCONCAT;
2279             PL_nextval[PL_nexttoke].ival = 0;
2280             force_next('(');
2281             if (*s == 'l')
2282                 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2283             else if (*s == 'u')
2284                 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2285             else if (*s == 'L')
2286                 PL_nextval[PL_nexttoke].ival = OP_LC;
2287             else if (*s == 'U')
2288                 PL_nextval[PL_nexttoke].ival = OP_UC;
2289             else if (*s == 'Q')
2290                 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2291             else
2292                 Perl_croak(aTHX_ "panic: yylex");
2293             PL_bufptr = s + 1;
2294             force_next(FUNC);
2295             if (PL_lex_starts) {
2296                 s = PL_bufptr;
2297                 PL_lex_starts = 0;
2298                 Aop(OP_CONCAT);
2299             }
2300             else
2301                 return yylex();
2302         }
2303
2304     case LEX_INTERPPUSH:
2305         return sublex_push();
2306
2307     case LEX_INTERPSTART:
2308         if (PL_bufptr == PL_bufend)
2309             return sublex_done();
2310         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2311               "### Interpolated variable at '%s'\n", PL_bufptr); });
2312         PL_expect = XTERM;
2313         PL_lex_dojoin = (*PL_bufptr == '@');
2314         PL_lex_state = LEX_INTERPNORMAL;
2315         if (PL_lex_dojoin) {
2316             PL_nextval[PL_nexttoke].ival = 0;
2317             force_next(',');
2318 #ifdef USE_5005THREADS
2319             PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
2320             PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
2321             force_next(PRIVATEREF);
2322 #else
2323             force_ident("\"", '$');
2324 #endif /* USE_5005THREADS */
2325             PL_nextval[PL_nexttoke].ival = 0;
2326             force_next('$');
2327             PL_nextval[PL_nexttoke].ival = 0;
2328             force_next('(');
2329             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2330             force_next(FUNC);
2331         }
2332         if (PL_lex_starts++) {
2333             s = PL_bufptr;
2334             Aop(OP_CONCAT);
2335         }
2336         return yylex();
2337
2338     case LEX_INTERPENDMAYBE:
2339         if (intuit_more(PL_bufptr)) {
2340             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2341             break;
2342         }
2343         /* FALL THROUGH */
2344
2345     case LEX_INTERPEND:
2346         if (PL_lex_dojoin) {
2347             PL_lex_dojoin = FALSE;
2348             PL_lex_state = LEX_INTERPCONCAT;
2349             return ')';
2350         }
2351         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2352             && SvEVALED(PL_lex_repl))
2353         {
2354             if (PL_bufptr != PL_bufend)
2355                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2356             PL_lex_repl = Nullsv;
2357         }
2358         /* FALLTHROUGH */
2359     case LEX_INTERPCONCAT:
2360 #ifdef DEBUGGING
2361         if (PL_lex_brackets)
2362             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2363 #endif
2364         if (PL_bufptr == PL_bufend)
2365             return sublex_done();
2366
2367         if (SvIVX(PL_linestr) == '\'') {
2368             SV *sv = newSVsv(PL_linestr);
2369             if (!PL_lex_inpat)
2370                 sv = tokeq(sv);
2371             else if ( PL_hints & HINT_NEW_RE )
2372                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2373             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2374             s = PL_bufend;
2375         }
2376         else {
2377             s = scan_const(PL_bufptr);
2378             if (*s == '\\')
2379                 PL_lex_state = LEX_INTERPCASEMOD;
2380             else
2381                 PL_lex_state = LEX_INTERPSTART;
2382         }
2383
2384         if (s != PL_bufptr) {
2385             PL_nextval[PL_nexttoke] = yylval;
2386             PL_expect = XTERM;
2387             force_next(THING);
2388             if (PL_lex_starts++)
2389                 Aop(OP_CONCAT);
2390             else {
2391                 PL_bufptr = s;
2392                 return yylex();
2393             }
2394         }
2395
2396         return yylex();
2397     case LEX_FORMLINE:
2398         PL_lex_state = LEX_NORMAL;
2399         s = scan_formline(PL_bufptr);
2400         if (!PL_lex_formbrack)
2401             goto rightbracket;
2402         OPERATOR(';');
2403     }
2404
2405     s = PL_bufptr;
2406     PL_oldoldbufptr = PL_oldbufptr;
2407     PL_oldbufptr = s;
2408     DEBUG_T( {
2409         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2410                       exp_name[PL_expect], s);
2411     } );
2412
2413   retry:
2414     switch (*s) {
2415     default:
2416         if (isIDFIRST_lazy_if(s,UTF))
2417             goto keylookup;
2418         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2419     case 4:
2420     case 26:
2421         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2422     case 0:
2423         if (!PL_rsfp) {
2424             PL_last_uni = 0;
2425             PL_last_lop = 0;
2426             if (PL_lex_brackets)
2427                 yyerror("Missing right curly or square bracket");
2428             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2429                         "### Tokener got EOF\n");
2430             } );
2431             TOKEN(0);
2432         }
2433         if (s++ < PL_bufend)
2434             goto retry;                 /* ignore stray nulls */
2435         PL_last_uni = 0;
2436         PL_last_lop = 0;
2437         if (!PL_in_eval && !PL_preambled) {
2438             PL_preambled = TRUE;
2439             sv_setpv(PL_linestr,incl_perldb());
2440             if (SvCUR(PL_linestr))
2441                 sv_catpv(PL_linestr,";");
2442             if (PL_preambleav){
2443                 while(AvFILLp(PL_preambleav) >= 0) {
2444                     SV *tmpsv = av_shift(PL_preambleav);
2445                     sv_catsv(PL_linestr, tmpsv);
2446                     sv_catpv(PL_linestr, ";");
2447                     sv_free(tmpsv);
2448                 }
2449                 sv_free((SV*)PL_preambleav);
2450                 PL_preambleav = NULL;
2451             }
2452             if (PL_minus_n || PL_minus_p) {
2453                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2454                 if (PL_minus_l)
2455                     sv_catpv(PL_linestr,"chomp;");
2456                 if (PL_minus_a) {
2457                     if (PL_minus_F) {
2458                         if (strchr("/'\"", *PL_splitstr)
2459                               && strchr(PL_splitstr + 1, *PL_splitstr))
2460                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2461                         else {
2462                             char delim;
2463                             s = "'~#\200\1'"; /* surely one char is unused...*/
2464                             while (s[1] && strchr(PL_splitstr, *s))  s++;
2465                             delim = *s;
2466                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2467                                       "q" + (delim == '\''), delim);
2468                             for (s = PL_splitstr; *s; s++) {
2469                                 if (*s == '\\')
2470                                     sv_catpvn(PL_linestr, "\\", 1);
2471                                 sv_catpvn(PL_linestr, s, 1);
2472                             }
2473                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2474                         }
2475                     }
2476                     else
2477                         sv_catpv(PL_linestr,"our @F=split(' ');");
2478                 }
2479             }
2480             sv_catpv(PL_linestr, "\n");
2481             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2482             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2483             PL_last_lop = PL_last_uni = Nullch;
2484             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2485                 SV *sv = NEWSV(85,0);
2486
2487                 sv_upgrade(sv, SVt_PVMG);
2488                 sv_setsv(sv,PL_linestr);
2489                 (void)SvIOK_on(sv);
2490                 SvIVX(sv) = 0;
2491                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2492             }
2493             goto retry;
2494         }
2495         do {
2496             bof = PL_rsfp ? TRUE : FALSE;
2497             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2498               fake_eof:
2499                 if (PL_rsfp) {
2500                     if (PL_preprocess && !PL_in_eval)
2501                         (void)PerlProc_pclose(PL_rsfp);
2502                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2503                         PerlIO_clearerr(PL_rsfp);
2504                     else
2505                         (void)PerlIO_close(PL_rsfp);
2506                     PL_rsfp = Nullfp;
2507                     PL_doextract = FALSE;
2508                 }
2509                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2510                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2511                     sv_catpv(PL_linestr,";}");
2512                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2513                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2514                     PL_last_lop = PL_last_uni = Nullch;
2515                     PL_minus_n = PL_minus_p = 0;
2516                     goto retry;
2517                 }
2518                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2519                 PL_last_lop = PL_last_uni = Nullch;
2520                 sv_setpv(PL_linestr,"");
2521                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2522             }
2523             /* if it looks like the start of a BOM, check if it in fact is */
2524             else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2525 #ifdef PERLIO_IS_STDIO
2526 #  ifdef __GNU_LIBRARY__
2527 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2528 #      define FTELL_FOR_PIPE_IS_BROKEN
2529 #    endif
2530 #  else
2531 #    ifdef __GLIBC__
2532 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2533 #        define FTELL_FOR_PIPE_IS_BROKEN
2534 #      endif
2535 #    endif
2536 #  endif
2537 #endif
2538 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2539                 /* This loses the possibility to detect the bof
2540                  * situation on perl -P when the libc5 is being used.
2541                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2542                  */
2543                 if (!PL_preprocess)
2544                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2545 #else
2546                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2547 #endif
2548                 if (bof) {
2549                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2550                     s = swallow_bom((U8*)s);
2551                 }
2552             }
2553             if (PL_doextract) {
2554                 /* Incest with pod. */
2555                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2556                     sv_setpv(PL_linestr, "");
2557                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2558                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2559                     PL_last_lop = PL_last_uni = Nullch;
2560                     PL_doextract = FALSE;
2561                 }
2562             }
2563             incline(s);
2564         } while (PL_doextract);
2565         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2566         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2567             SV *sv = NEWSV(85,0);
2568
2569             sv_upgrade(sv, SVt_PVMG);
2570             sv_setsv(sv,PL_linestr);
2571             (void)SvIOK_on(sv);
2572             SvIVX(sv) = 0;
2573             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2574         }
2575         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2576         PL_last_lop = PL_last_uni = Nullch;
2577         if (CopLINE(PL_curcop) == 1) {
2578             while (s < PL_bufend && isSPACE(*s))
2579                 s++;
2580             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2581                 s++;
2582             d = Nullch;
2583             if (!PL_in_eval) {
2584                 if (*s == '#' && *(s+1) == '!')
2585                     d = s + 2;
2586 #ifdef ALTERNATE_SHEBANG
2587                 else {
2588                     static char as[] = ALTERNATE_SHEBANG;
2589                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2590                         d = s + (sizeof(as) - 1);
2591                 }
2592 #endif /* ALTERNATE_SHEBANG */
2593             }
2594             if (d) {
2595                 char *ipath;
2596                 char *ipathend;
2597
2598                 while (isSPACE(*d))
2599                     d++;
2600                 ipath = d;
2601                 while (*d && !isSPACE(*d))
2602                     d++;
2603                 ipathend = d;
2604
2605 #ifdef ARG_ZERO_IS_SCRIPT
2606                 if (ipathend > ipath) {
2607                     /*
2608                      * HP-UX (at least) sets argv[0] to the script name,
2609                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2610                      * at least, set argv[0] to the basename of the Perl
2611                      * interpreter. So, having found "#!", we'll set it right.
2612                      */
2613                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2614                     assert(SvPOK(x) || SvGMAGICAL(x));
2615                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2616                         sv_setpvn(x, ipath, ipathend - ipath);
2617                         SvSETMAGIC(x);
2618                     }
2619                     else {
2620                         STRLEN blen;
2621                         STRLEN llen;
2622                         char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2623                         char *lstart = SvPV(x,llen);
2624                         if (llen < blen) {
2625                             bstart += blen - llen;
2626                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2627                                 sv_setpvn(x, ipath, ipathend - ipath);
2628                                 SvSETMAGIC(x);
2629                             }
2630                         }
2631                     }
2632                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2633                 }
2634 #endif /* ARG_ZERO_IS_SCRIPT */
2635
2636                 /*
2637                  * Look for options.
2638                  */
2639                 d = instr(s,"perl -");
2640                 if (!d) {
2641                     d = instr(s,"perl");
2642 #if defined(DOSISH)
2643                     /* avoid getting into infinite loops when shebang
2644                      * line contains "Perl" rather than "perl" */
2645                     if (!d) {
2646                         for (d = ipathend-4; d >= ipath; --d) {
2647                             if ((*d == 'p' || *d == 'P')
2648                                 && !ibcmp(d, "perl", 4))
2649                             {
2650                                 break;
2651                             }
2652                         }
2653                         if (d < ipath)
2654                             d = Nullch;
2655                     }
2656 #endif
2657                 }
2658 #ifdef ALTERNATE_SHEBANG
2659                 /*
2660                  * If the ALTERNATE_SHEBANG on this system starts with a
2661                  * character that can be part of a Perl expression, then if
2662                  * we see it but not "perl", we're probably looking at the
2663                  * start of Perl code, not a request to hand off to some
2664                  * other interpreter.  Similarly, if "perl" is there, but
2665                  * not in the first 'word' of the line, we assume the line
2666                  * contains the start of the Perl program.
2667                  */
2668                 if (d && *s != '#') {
2669                     char *c = ipath;
2670                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2671                         c++;
2672                     if (c < d)
2673                         d = Nullch;     /* "perl" not in first word; ignore */
2674                     else
2675                         *s = '#';       /* Don't try to parse shebang line */
2676                 }
2677 #endif /* ALTERNATE_SHEBANG */
2678 #ifndef MACOS_TRADITIONAL
2679                 if (!d &&
2680                     *s == '#' &&
2681                     ipathend > ipath &&
2682                     !PL_minus_c &&
2683                     !instr(s,"indir") &&
2684                     instr(PL_origargv[0],"perl"))
2685                 {
2686                     char **newargv;
2687
2688                     *ipathend = '\0';
2689                     s = ipathend + 1;
2690                     while (s < PL_bufend && isSPACE(*s))
2691                         s++;
2692                     if (s < PL_bufend) {
2693                         Newz(899,newargv,PL_origargc+3,char*);
2694                         newargv[1] = s;
2695                         while (s < PL_bufend && !isSPACE(*s))
2696                             s++;
2697                         *s = '\0';
2698                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2699                     }
2700                     else
2701                         newargv = PL_origargv;
2702                     newargv[0] = ipath;
2703                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2704                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2705                 }
2706 #endif
2707                 if (d) {
2708                     U32 oldpdb = PL_perldb;
2709                     bool oldn = PL_minus_n;
2710                     bool oldp = PL_minus_p;
2711
2712                     while (*d && !isSPACE(*d)) d++;
2713                     while (SPACE_OR_TAB(*d)) d++;
2714
2715                     if (*d++ == '-') {
2716                         bool switches_done = PL_doswitches;
2717                         do {
2718                             if (*d == 'M' || *d == 'm') {
2719                                 char *m = d;
2720                                 while (*d && !isSPACE(*d)) d++;
2721                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2722                                       (int)(d - m), m);
2723                             }
2724                             d = moreswitches(d);
2725                         } while (d);
2726                         if ((PERLDB_LINE && !oldpdb) ||
2727                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2728                               /* if we have already added "LINE: while (<>) {",
2729                                  we must not do it again */
2730                         {
2731                             sv_setpv(PL_linestr, "");
2732                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2733                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2734                             PL_last_lop = PL_last_uni = Nullch;
2735                             PL_preambled = FALSE;
2736                             if (PERLDB_LINE)
2737                                 (void)gv_fetchfile(PL_origfilename);
2738                             goto retry;
2739                         }
2740                         if (PL_doswitches && !switches_done) {
2741                             int argc = PL_origargc;
2742                             char **argv = PL_origargv;
2743                             do {
2744                                 argc--,argv++;
2745                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2746                             init_argv_symbols(argc,argv);
2747                         }
2748                     }
2749                 }
2750             }
2751         }
2752         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2753             PL_bufptr = s;
2754             PL_lex_state = LEX_FORMLINE;
2755             return yylex();
2756         }
2757         goto retry;
2758     case '\r':
2759 #ifdef PERL_STRICT_CR
2760         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2761         Perl_croak(aTHX_
2762       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2763 #endif
2764     case ' ': case '\t': case '\f': case 013:
2765 #ifdef MACOS_TRADITIONAL
2766     case '\312':
2767 #endif
2768         s++;
2769         goto retry;
2770     case '#':
2771     case '\n':
2772         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2773             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2774                 /* handle eval qq[#line 1 "foo"\n ...] */
2775                 CopLINE_dec(PL_curcop);
2776                 incline(s);
2777             }
2778             d = PL_bufend;
2779             while (s < d && *s != '\n')
2780                 s++;
2781             if (s < d)
2782                 s++;
2783             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2784               Perl_croak(aTHX_ "panic: input overflow");
2785             incline(s);
2786             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2787                 PL_bufptr = s;
2788                 PL_lex_state = LEX_FORMLINE;
2789                 return yylex();
2790             }
2791         }
2792         else {
2793             *s = '\0';
2794             PL_bufend = s;
2795         }
2796         goto retry;
2797     case '-':
2798         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2799             I32 ftst = 0;
2800
2801             s++;
2802             PL_bufptr = s;
2803             tmp = *s++;
2804
2805             while (s < PL_bufend && SPACE_OR_TAB(*s))
2806                 s++;
2807
2808             if (strnEQ(s,"=>",2)) {
2809                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2810                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2811                             "### Saw unary minus before =>, forcing word '%s'\n", s);
2812                 } );
2813                 OPERATOR('-');          /* unary minus */
2814             }
2815             PL_last_uni = PL_oldbufptr;
2816             switch (tmp) {
2817             case 'r': ftst = OP_FTEREAD;        break;
2818             case 'w': ftst = OP_FTEWRITE;       break;
2819             case 'x': ftst = OP_FTEEXEC;        break;
2820             case 'o': ftst = OP_FTEOWNED;       break;
2821             case 'R': ftst = OP_FTRREAD;        break;
2822             case 'W': ftst = OP_FTRWRITE;       break;
2823             case 'X': ftst = OP_FTREXEC;        break;
2824             case 'O': ftst = OP_FTROWNED;       break;
2825             case 'e': ftst = OP_FTIS;           break;
2826             case 'z': ftst = OP_FTZERO;         break;
2827             case 's': ftst = OP_FTSIZE;         break;
2828             case 'f': ftst = OP_FTFILE;         break;
2829             case 'd': ftst = OP_FTDIR;          break;
2830             case 'l': ftst = OP_FTLINK;         break;
2831             case 'p': ftst = OP_FTPIPE;         break;
2832             case 'S': ftst = OP_FTSOCK;         break;
2833             case 'u': ftst = OP_FTSUID;         break;
2834             case 'g': ftst = OP_FTSGID;         break;
2835             case 'k': ftst = OP_FTSVTX;         break;
2836             case 'b': ftst = OP_FTBLK;          break;
2837             case 'c': ftst = OP_FTCHR;          break;
2838             case 't': ftst = OP_FTTTY;          break;
2839             case 'T': ftst = OP_FTTEXT;         break;
2840             case 'B': ftst = OP_FTBINARY;       break;
2841             case 'M': case 'A': case 'C':
2842                 gv_fetchpv("\024",TRUE, SVt_PV);
2843                 switch (tmp) {
2844                 case 'M': ftst = OP_FTMTIME;    break;
2845                 case 'A': ftst = OP_FTATIME;    break;
2846                 case 'C': ftst = OP_FTCTIME;    break;
2847                 default:                        break;
2848                 }
2849                 break;
2850             default:
2851                 break;
2852             }
2853             if (ftst) {
2854                 PL_last_lop_op = (OPCODE)ftst;
2855                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2856                         "### Saw file test %c\n", (int)ftst);
2857                 } );
2858                 FTST(ftst);
2859             }
2860             else {
2861                 /* Assume it was a minus followed by a one-letter named
2862                  * subroutine call (or a -bareword), then. */
2863                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2864                         "### %c looked like a file test but was not\n",
2865                         (int)ftst);
2866                 } );
2867                 s -= 2;
2868             }
2869         }
2870         tmp = *s++;
2871         if (*s == tmp) {
2872             s++;
2873             if (PL_expect == XOPERATOR)
2874                 TERM(POSTDEC);
2875             else
2876                 OPERATOR(PREDEC);
2877         }
2878         else if (*s == '>') {
2879             s++;
2880             s = skipspace(s);
2881             if (isIDFIRST_lazy_if(s,UTF)) {
2882                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2883                 TOKEN(ARROW);
2884             }
2885             else if (*s == '$')
2886                 OPERATOR(ARROW);
2887             else
2888                 TERM(ARROW);
2889         }
2890         if (PL_expect == XOPERATOR)
2891             Aop(OP_SUBTRACT);
2892         else {
2893             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2894                 check_uni();
2895             OPERATOR('-');              /* unary minus */
2896         }
2897
2898     case '+':
2899         tmp = *s++;
2900         if (*s == tmp) {
2901             s++;
2902             if (PL_expect == XOPERATOR)
2903                 TERM(POSTINC);
2904             else
2905                 OPERATOR(PREINC);
2906         }
2907         if (PL_expect == XOPERATOR)
2908             Aop(OP_ADD);
2909         else {
2910             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2911                 check_uni();
2912             OPERATOR('+');
2913         }
2914
2915     case '*':
2916         if (PL_expect != XOPERATOR) {
2917             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2918             PL_expect = XOPERATOR;
2919             force_ident(PL_tokenbuf, '*');
2920             if (!*PL_tokenbuf)
2921                 PREREF('*');
2922             TERM('*');
2923         }
2924         s++;
2925         if (*s == '*') {
2926             s++;
2927             PWop(OP_POW);
2928         }
2929         Mop(OP_MULTIPLY);
2930
2931     case '%':
2932         if (PL_expect == XOPERATOR) {
2933             ++s;
2934             Mop(OP_MODULO);
2935         }
2936         PL_tokenbuf[0] = '%';
2937         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2938         if (!PL_tokenbuf[1]) {
2939             if (s == PL_bufend)
2940                 yyerror("Final % should be \\% or %name");
2941             PREREF('%');
2942         }
2943         PL_pending_ident = '%';
2944         TERM('%');
2945
2946     case '^':
2947         s++;
2948         BOop(OP_BIT_XOR);
2949     case '[':
2950         PL_lex_brackets++;
2951         /* FALL THROUGH */
2952     case '~':
2953     case ',':
2954         tmp = *s++;
2955         OPERATOR(tmp);
2956     case ':':
2957         if (s[1] == ':') {
2958             len = 0;
2959             goto just_a_word;
2960         }
2961         s++;
2962         switch (PL_expect) {
2963             OP *attrs;
2964         case XOPERATOR:
2965             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2966                 break;
2967             PL_bufptr = s;      /* update in case we back off */
2968             goto grabattrs;
2969         case XATTRBLOCK:
2970             PL_expect = XBLOCK;
2971             goto grabattrs;
2972         case XATTRTERM:
2973             PL_expect = XTERMBLOCK;
2974          grabattrs:
2975             s = skipspace(s);
2976             attrs = Nullop;
2977             while (isIDFIRST_lazy_if(s,UTF)) {
2978                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2979                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
2980                     if (tmp < 0) tmp = -tmp;
2981                     switch (tmp) {
2982                     case KEY_or:
2983                     case KEY_and:
2984                     case KEY_err:
2985                     case KEY_for:
2986                     case KEY_unless:
2987                     case KEY_if:
2988                     case KEY_while:
2989                     case KEY_until:
2990                         goto got_attrs;
2991                     default:
2992                         break;
2993                     }
2994                 }
2995                 if (*d == '(') {
2996                     d = scan_str(d,TRUE,TRUE);
2997                     if (!d) {
2998                         /* MUST advance bufptr here to avoid bogus
2999                            "at end of line" context messages from yyerror().
3000                          */
3001                         PL_bufptr = s + len;
3002                         yyerror("Unterminated attribute parameter in attribute list");
3003                         if (attrs)
3004                             op_free(attrs);
3005                         return 0;       /* EOF indicator */
3006                     }
3007                 }
3008                 if (PL_lex_stuff) {
3009                     SV *sv = newSVpvn(s, len);
3010                     sv_catsv(sv, PL_lex_stuff);
3011                     attrs = append_elem(OP_LIST, attrs,
3012                                         newSVOP(OP_CONST, 0, sv));
3013                     SvREFCNT_dec(PL_lex_stuff);
3014                     PL_lex_stuff = Nullsv;
3015                 }
3016                 else {
3017                     /* NOTE: any CV attrs applied here need to be part of
3018                        the CVf_BUILTIN_ATTRS define in cv.h! */
3019                     if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3020                         CvLVALUE_on(PL_compcv);
3021                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3022                         CvLOCKED_on(PL_compcv);
3023                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3024                         CvMETHOD_on(PL_compcv);
3025 #ifdef USE_ITHREADS
3026                     else if (PL_in_my == KEY_our && len == 6 &&
3027                              strnEQ(s, "unique", len))
3028                         GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3029 #endif
3030                     /* After we've set the flags, it could be argued that
3031                        we don't need to do the attributes.pm-based setting
3032                        process, and shouldn't bother appending recognized
3033                        flags.  To experiment with that, uncomment the
3034                        following "else".  (Note that's already been
3035                        uncommented.  That keeps the above-applied built-in
3036                        attributes from being intercepted (and possibly
3037                        rejected) by a package's attribute routines, but is
3038                        justified by the performance win for the common case
3039                        of applying only built-in attributes.) */
3040                     else
3041                         attrs = append_elem(OP_LIST, attrs,
3042                                             newSVOP(OP_CONST, 0,
3043                                                     newSVpvn(s, len)));
3044                 }
3045                 s = skipspace(d);
3046                 if (*s == ':' && s[1] != ':')
3047                     s = skipspace(s+1);
3048                 else if (s == d)
3049                     break;      /* require real whitespace or :'s */
3050             }
3051             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3052             if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3053                 char q = ((*s == '\'') ? '"' : '\'');
3054                 /* If here for an expression, and parsed no attrs, back off. */
3055                 if (tmp == '=' && !attrs) {
3056                     s = PL_bufptr;
3057                     break;
3058                 }
3059                 /* MUST advance bufptr here to avoid bogus "at end of line"
3060                    context messages from yyerror().
3061                  */
3062                 PL_bufptr = s;
3063                 if (!*s)
3064                     yyerror("Unterminated attribute list");
3065                 else
3066                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3067                                       q, *s, q));
3068                 if (attrs)
3069                     op_free(attrs);
3070                 OPERATOR(':');
3071             }
3072         got_attrs:
3073             if (attrs) {
3074                 PL_nextval[PL_nexttoke].opval = attrs;
3075                 force_next(THING);
3076             }
3077             TOKEN(COLONATTR);
3078         }
3079         OPERATOR(':');
3080     case '(':
3081         s++;
3082         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3083             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3084         else
3085             PL_expect = XTERM;
3086         TOKEN('(');
3087     case ';':
3088         CLINE;
3089         tmp = *s++;
3090         OPERATOR(tmp);
3091     case ')':
3092         tmp = *s++;
3093         s = skipspace(s);
3094         if (*s == '{')
3095             PREBLOCK(tmp);
3096         TERM(tmp);
3097     case ']':
3098         s++;
3099         if (PL_lex_brackets <= 0)
3100             yyerror("Unmatched right square bracket");
3101         else
3102             --PL_lex_brackets;
3103         if (PL_lex_state == LEX_INTERPNORMAL) {
3104             if (PL_lex_brackets == 0) {
3105                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3106                     PL_lex_state = LEX_INTERPEND;
3107             }
3108         }
3109         TERM(']');
3110     case '{':
3111       leftbracket:
3112         s++;
3113         if (PL_lex_brackets > 100) {
3114             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
3115             if (newlb != PL_lex_brackstack) {
3116                 SAVEFREEPV(newlb);
3117                 PL_lex_brackstack = newlb;
3118             }
3119         }
3120         switch (PL_expect) {
3121         case XTERM:
3122             if (PL_lex_formbrack) {
3123                 s--;
3124                 PRETERMBLOCK(DO);
3125             }
3126             if (PL_oldoldbufptr == PL_last_lop)
3127                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3128             else
3129                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3130             OPERATOR(HASHBRACK);
3131         case XOPERATOR:
3132             while (s < PL_bufend && SPACE_OR_TAB(*s))
3133                 s++;
3134             d = s;
3135             PL_tokenbuf[0] = '\0';
3136             if (d < PL_bufend && *d == '-') {
3137                 PL_tokenbuf[0] = '-';
3138                 d++;
3139                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3140                     d++;
3141             }
3142             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3143                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3144                               FALSE, &len);
3145                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3146                     d++;
3147                 if (*d == '}') {
3148                     char minus = (PL_tokenbuf[0] == '-');
3149                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3150                     if (minus)
3151                         force_next('-');
3152                 }
3153             }
3154             /* FALL THROUGH */
3155         case XATTRBLOCK:
3156         case XBLOCK:
3157             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3158             PL_expect = XSTATE;
3159             break;
3160         case XATTRTERM:
3161         case XTERMBLOCK:
3162             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3163             PL_expect = XSTATE;
3164             break;
3165         default: {
3166                 char *t;
3167                 if (PL_oldoldbufptr == PL_last_lop)
3168                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3169                 else
3170                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3171                 s = skipspace(s);
3172                 if (*s == '}') {
3173                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3174                         PL_expect = XTERM;
3175                         /* This hack is to get the ${} in the message. */
3176                         PL_bufptr = s+1;
3177                         yyerror("syntax error");
3178                         break;
3179                     }
3180                     OPERATOR(HASHBRACK);
3181                 }
3182                 /* This hack serves to disambiguate a pair of curlies
3183                  * as being a block or an anon hash.  Normally, expectation
3184                  * determines that, but in cases where we're not in a
3185                  * position to expect anything in particular (like inside
3186                  * eval"") we have to resolve the ambiguity.  This code
3187                  * covers the case where the first term in the curlies is a
3188                  * quoted string.  Most other cases need to be explicitly
3189                  * disambiguated by prepending a `+' before the opening
3190                  * curly in order to force resolution as an anon hash.
3191                  *
3192                  * XXX should probably propagate the outer expectation
3193                  * into eval"" to rely less on this hack, but that could
3194                  * potentially break current behavior of eval"".
3195                  * GSAR 97-07-21
3196                  */
3197                 t = s;
3198                 if (*s == '\'' || *s == '"' || *s == '`') {
3199                     /* common case: get past first string, handling escapes */
3200                     for (t++; t < PL_bufend && *t != *s;)
3201                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3202                             t++;
3203                     t++;
3204                 }
3205                 else if (*s == 'q') {
3206                     if (++t < PL_bufend
3207                         && (!isALNUM(*t)
3208                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3209                                 && !isALNUM(*t))))
3210                     {
3211                         char *tmps;
3212                         char open, close, term;
3213                         I32 brackets = 1;
3214
3215                         while (t < PL_bufend && isSPACE(*t))
3216                             t++;
3217                         term = *t;
3218                         open = term;
3219                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3220                             term = tmps[5];
3221                         close = term;
3222                         if (open == close)
3223                             for (t++; t < PL_bufend; t++) {
3224                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3225                                     t++;
3226                                 else if (*t == open)
3227                                     break;
3228                             }
3229                         else
3230                             for (t++; t < PL_bufend; t++) {
3231                                 if (*t == '\\' && t+1 < PL_bufend)
3232                                     t++;
3233                                 else if (*t == close && --brackets <= 0)
3234                                     break;
3235                                 else if (*t == open)
3236                                     brackets++;
3237                             }
3238                     }
3239                     t++;
3240                 }
3241                 else if (isALNUM_lazy_if(t,UTF)) {
3242                     t += UTF8SKIP(t);
3243                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3244                          t += UTF8SKIP(t);
3245                 }
3246                 while (t < PL_bufend && isSPACE(*t))
3247                     t++;
3248                 /* if comma follows first term, call it an anon hash */
3249                 /* XXX it could be a comma expression with loop modifiers */
3250                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3251                                    || (*t == '=' && t[1] == '>')))
3252                     OPERATOR(HASHBRACK);
3253                 if (PL_expect == XREF)
3254                     PL_expect = XTERM;
3255                 else {
3256                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3257                     PL_expect = XSTATE;
3258                 }
3259             }
3260             break;
3261         }
3262         yylval.ival = CopLINE(PL_curcop);
3263         if (isSPACE(*s) || *s == '#')
3264             PL_copline = NOLINE;   /* invalidate current command line number */
3265         TOKEN('{');
3266     case '}':
3267       rightbracket:
3268         s++;
3269         if (PL_lex_brackets <= 0)
3270             yyerror("Unmatched right curly bracket");
3271         else
3272             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3273         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3274             PL_lex_formbrack = 0;
3275         if (PL_lex_state == LEX_INTERPNORMAL) {
3276             if (PL_lex_brackets == 0) {
3277                 if (PL_expect & XFAKEBRACK) {
3278                     PL_expect &= XENUMMASK;
3279                     PL_lex_state = LEX_INTERPEND;
3280                     PL_bufptr = s;
3281                     return yylex();     /* ignore fake brackets */
3282                 }
3283                 if (*s == '-' && s[1] == '>')
3284                     PL_lex_state = LEX_INTERPENDMAYBE;
3285                 else if (*s != '[' && *s != '{')
3286                     PL_lex_state = LEX_INTERPEND;
3287             }
3288         }
3289         if (PL_expect & XFAKEBRACK) {
3290             PL_expect &= XENUMMASK;
3291             PL_bufptr = s;
3292             return yylex();             /* ignore fake brackets */
3293         }
3294         force_next('}');
3295         TOKEN(';');
3296     case '&':
3297         s++;
3298         tmp = *s++;
3299         if (tmp == '&')
3300             AOPERATOR(ANDAND);
3301         s--;
3302         if (PL_expect == XOPERATOR) {
3303             if (ckWARN(WARN_SEMICOLON)
3304                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3305             {
3306                 CopLINE_dec(PL_curcop);
3307                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3308                 CopLINE_inc(PL_curcop);
3309             }
3310             BAop(OP_BIT_AND);
3311         }
3312
3313         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3314         if (*PL_tokenbuf) {
3315             PL_expect = XOPERATOR;
3316             force_ident(PL_tokenbuf, '&');
3317         }
3318         else
3319             PREREF('&');
3320         yylval.ival = (OPpENTERSUB_AMPER<<8);
3321         TERM('&');
3322
3323     case '|':
3324         s++;
3325         tmp = *s++;
3326         if (tmp == '|')
3327             AOPERATOR(OROR);
3328         s--;
3329         BOop(OP_BIT_OR);
3330     case '=':
3331         s++;
3332         tmp = *s++;
3333         if (tmp == '=')
3334             Eop(OP_EQ);
3335         if (tmp == '>')
3336             OPERATOR(',');
3337         if (tmp == '~')
3338             PMop(OP_MATCH);
3339         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3340             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3341         s--;
3342         if (PL_expect == XSTATE && isALPHA(tmp) &&
3343                 (s == PL_linestart+1 || s[-2] == '\n') )
3344         {
3345             if (PL_in_eval && !PL_rsfp) {
3346                 d = PL_bufend;
3347                 while (s < d) {
3348                     if (*s++ == '\n') {
3349                         incline(s);
3350                         if (strnEQ(s,"=cut",4)) {
3351                             s = strchr(s,'\n');
3352                             if (s)
3353                                 s++;
3354                             else
3355                                 s = d;
3356                             incline(s);
3357                             goto retry;
3358                         }
3359                     }
3360                 }
3361                 goto retry;
3362             }
3363             s = PL_bufend;
3364             PL_doextract = TRUE;
3365             goto retry;
3366         }
3367         if (PL_lex_brackets < PL_lex_formbrack) {
3368             char *t;
3369 #ifdef PERL_STRICT_CR
3370             for (t = s; SPACE_OR_TAB(*t); t++) ;
3371 #else
3372             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3373 #endif
3374             if (*t == '\n' || *t == '#') {
3375                 s--;
3376                 PL_expect = XBLOCK;
3377                 goto leftbracket;
3378             }
3379         }
3380         yylval.ival = 0;
3381         OPERATOR(ASSIGNOP);
3382     case '!':
3383         s++;
3384         tmp = *s++;
3385         if (tmp == '=')
3386             Eop(OP_NE);
3387         if (tmp == '~')
3388             PMop(OP_NOT);
3389         s--;
3390         OPERATOR('!');
3391     case '<':
3392         if (PL_expect != XOPERATOR) {
3393             if (s[1] != '<' && !strchr(s,'>'))
3394                 check_uni();
3395             if (s[1] == '<')
3396                 s = scan_heredoc(s);
3397             else
3398                 s = scan_inputsymbol(s);
3399             TERM(sublex_start());
3400         }
3401         s++;
3402         tmp = *s++;
3403         if (tmp == '<')
3404             SHop(OP_LEFT_SHIFT);
3405         if (tmp == '=') {
3406             tmp = *s++;
3407             if (tmp == '>')
3408                 Eop(OP_NCMP);
3409             s--;
3410             Rop(OP_LE);
3411         }
3412         s--;
3413         Rop(OP_LT);
3414     case '>':
3415         s++;
3416         tmp = *s++;
3417         if (tmp == '>')
3418             SHop(OP_RIGHT_SHIFT);
3419         if (tmp == '=')
3420             Rop(OP_GE);
3421         s--;
3422         Rop(OP_GT);
3423
3424     case '$':
3425         CLINE;
3426
3427         if (PL_expect == XOPERATOR) {
3428             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3429                 PL_expect = XTERM;
3430                 depcom();
3431                 return ','; /* grandfather non-comma-format format */
3432             }
3433         }
3434
3435         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3436             PL_tokenbuf[0] = '@';
3437             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3438                            sizeof PL_tokenbuf - 1, FALSE);
3439             if (PL_expect == XOPERATOR)
3440                 no_op("Array length", s);
3441             if (!PL_tokenbuf[1])
3442                 PREREF(DOLSHARP);
3443             PL_expect = XOPERATOR;
3444             PL_pending_ident = '#';
3445             TOKEN(DOLSHARP);
3446         }
3447
3448         PL_tokenbuf[0] = '$';
3449         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3450                        sizeof PL_tokenbuf - 1, FALSE);
3451         if (PL_expect == XOPERATOR)
3452             no_op("Scalar", s);
3453         if (!PL_tokenbuf[1]) {
3454             if (s == PL_bufend)
3455                 yyerror("Final $ should be \\$ or $name");
3456             PREREF('$');
3457         }
3458
3459         /* This kludge not intended to be bulletproof. */
3460         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3461             yylval.opval = newSVOP(OP_CONST, 0,
3462                                    newSViv(PL_compiling.cop_arybase));
3463             yylval.opval->op_private = OPpCONST_ARYBASE;
3464             TERM(THING);
3465         }
3466
3467         d = s;
3468         tmp = (I32)*s;
3469         if (PL_lex_state == LEX_NORMAL)
3470             s = skipspace(s);
3471
3472         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3473             char *t;
3474             if (*s == '[') {
3475                 PL_tokenbuf[0] = '@';
3476                 if (ckWARN(WARN_SYNTAX)) {
3477                     for(t = s + 1;
3478                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3479                         t++) ;
3480                     if (*t++ == ',') {
3481                         PL_bufptr = skipspace(PL_bufptr);
3482                         while (t < PL_bufend && *t != ']')
3483                             t++;
3484                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3485                                 "Multidimensional syntax %.*s not supported",
3486                                 (t - PL_bufptr) + 1, PL_bufptr);
3487                     }
3488                 }
3489             }
3490             else if (*s == '{') {
3491                 PL_tokenbuf[0] = '%';
3492                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3493                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3494                 {
3495                     char tmpbuf[sizeof PL_tokenbuf];
3496                     STRLEN len;
3497                     for (t++; isSPACE(*t); t++) ;
3498                     if (isIDFIRST_lazy_if(t,UTF)) {
3499                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3500                         for (; isSPACE(*t); t++) ;
3501                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3502                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3503                                 "You need to quote \"%s\"", tmpbuf);
3504                     }
3505                 }
3506             }
3507         }
3508
3509         PL_expect = XOPERATOR;
3510         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3511             bool islop = (PL_last_lop == PL_oldoldbufptr);
3512             if (!islop || PL_last_lop_op == OP_GREPSTART)
3513                 PL_expect = XOPERATOR;
3514             else if (strchr("$@\"'`q", *s))
3515                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3516             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3517                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3518             else if (isIDFIRST_lazy_if(s,UTF)) {
3519                 char tmpbuf[sizeof PL_tokenbuf];
3520                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3521                 if ((tmp = keyword(tmpbuf, len))) {
3522                     /* binary operators exclude handle interpretations */
3523                     switch (tmp) {
3524                     case -KEY_x:
3525                     case -KEY_eq:
3526                     case -KEY_ne:
3527                     case -KEY_gt:
3528                     case -KEY_lt:
3529                     case -KEY_ge:
3530                     case -KEY_le:
3531                     case -KEY_cmp:
3532                         break;
3533                     default:
3534                         PL_expect = XTERM;      /* e.g. print $fh length() */
3535                         break;
3536                     }
3537                 }
3538                 else {
3539                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
3540                     if (gv && GvCVu(gv))
3541                         PL_expect = XTERM;      /* e.g. print $fh subr() */
3542                 }
3543             }
3544             else if (isDIGIT(*s))
3545                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3546             else if (*s == '.' && isDIGIT(s[1]))
3547                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3548             else if (strchr("?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3549                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3550             else if (*s == '/') {
3551                 if(s[1] == '/') {
3552                     PL_expect=XOPERATOR;
3553                 }
3554                 else {
3555                     PL_expect=XTERM;
3556                 }
3557             }
3558             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3559                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3560         }
3561         PL_pending_ident = '$';
3562         TOKEN('$');
3563
3564     case '@':
3565         if (PL_expect == XOPERATOR)
3566             no_op("Array", s);
3567         PL_tokenbuf[0] = '@';
3568         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3569         if (!PL_tokenbuf[1]) {
3570             if (s == PL_bufend)
3571                 yyerror("Final @ should be \\@ or @name");
3572             PREREF('@');
3573         }
3574         if (PL_lex_state == LEX_NORMAL)
3575             s = skipspace(s);
3576         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3577             if (*s == '{')
3578                 PL_tokenbuf[0] = '%';
3579
3580             /* Warn about @ where they meant $. */
3581             if (ckWARN(WARN_SYNTAX)) {
3582                 if (*s == '[' || *s == '{') {
3583                     char *t = s + 1;
3584                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3585                         t++;
3586                     if (*t == '}' || *t == ']') {
3587                         t++;
3588                         PL_bufptr = skipspace(PL_bufptr);
3589                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3590                             "Scalar value %.*s better written as $%.*s",
3591                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3592                     }
3593                 }
3594             }
3595         }
3596         PL_pending_ident = '@';
3597         TERM('@');
3598
3599      case '/':                  /* may be division, defined-or, or pattern */
3600      case '?':                  /* may either be conditional or pattern */
3601          if(PL_expect == XOPERATOR) {
3602              tmp = *s++;
3603              if(tmp == '?') {
3604                   OPERATOR('?');
3605              }
3606              else {
3607                  tmp = *s++;
3608                  if(tmp == '/') {
3609                      /* A // operator. */
3610                     AOPERATOR(DORDOR);
3611                  }
3612                  else {
3613                      s--;
3614                      Mop(OP_DIVIDE);
3615                  }
3616              }
3617          }
3618          else {
3619              /* Disable warning on "study /blah/" */
3620              if (PL_oldoldbufptr == PL_last_uni
3621               && (*PL_last_uni != 's' || s - PL_last_uni < 5
3622                   || memNE(PL_last_uni, "study", 5)
3623                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
3624               ))
3625                  check_uni();
3626              s = scan_pat(s,OP_MATCH);
3627              TERM(sublex_start());
3628          }
3629
3630     case '.':
3631         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3632 #ifdef PERL_STRICT_CR
3633             && s[1] == '\n'
3634 #else
3635             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3636 #endif
3637             && (s == PL_linestart || s[-1] == '\n') )
3638         {
3639             PL_lex_formbrack = 0;
3640             PL_expect = XSTATE;
3641             goto rightbracket;
3642         }
3643         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3644             tmp = *s++;
3645             if (*s == tmp) {
3646                 s++;
3647                 if (*s == tmp) {
3648                     s++;
3649                     yylval.ival = OPf_SPECIAL;
3650                 }
3651                 else
3652                     yylval.ival = 0;
3653                 OPERATOR(DOTDOT);
3654             }
3655             if (PL_expect != XOPERATOR)
3656                 check_uni();
3657             Aop(OP_CONCAT);
3658         }
3659         /* FALL THROUGH */
3660     case '0': case '1': case '2': case '3': case '4':
3661     case '5': case '6': case '7': case '8': case '9':
3662         s = scan_num(s, &yylval);
3663         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3664                     "### Saw number in '%s'\n", s);
3665         } );
3666         if (PL_expect == XOPERATOR)
3667             no_op("Number",s);
3668         TERM(THING);
3669
3670     case '\'':
3671         s = scan_str(s,FALSE,FALSE);
3672         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3673                     "### Saw string before '%s'\n", s);
3674         } );
3675         if (PL_expect == XOPERATOR) {
3676             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3677                 PL_expect = XTERM;
3678                 depcom();
3679                 return ',';     /* grandfather non-comma-format format */
3680             }
3681             else
3682                 no_op("String",s);
3683         }
3684         if (!s)
3685             missingterm((char*)0);
3686         yylval.ival = OP_CONST;
3687         TERM(sublex_start());
3688
3689     case '"':
3690         s = scan_str(s,FALSE,FALSE);
3691         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3692                     "### Saw string before '%s'\n", s);
3693         } );
3694         if (PL_expect == XOPERATOR) {
3695             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3696                 PL_expect = XTERM;
3697                 depcom();
3698                 return ',';     /* grandfather non-comma-format format */
3699             }
3700             else
3701                 no_op("String",s);
3702         }
3703         if (!s)
3704             missingterm((char*)0);
3705         yylval.ival = OP_CONST;
3706         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3707             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3708                 yylval.ival = OP_STRINGIFY;
3709                 break;
3710             }
3711         }
3712         TERM(sublex_start());
3713
3714     case '`':
3715         s = scan_str(s,FALSE,FALSE);
3716         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3717                     "### Saw backtick string before '%s'\n", s);
3718         } );
3719         if (PL_expect == XOPERATOR)
3720             no_op("Backticks",s);
3721         if (!s)
3722             missingterm((char*)0);
3723         yylval.ival = OP_BACKTICK;
3724         set_csh();
3725         TERM(sublex_start());
3726
3727     case '\\':
3728         s++;
3729         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3730             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3731                         *s, *s);
3732         if (PL_expect == XOPERATOR)
3733             no_op("Backslash",s);
3734         OPERATOR(REFGEN);
3735
3736     case 'v':
3737         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3738             char *start = s;
3739             start++;
3740             start++;
3741             while (isDIGIT(*start) || *start == '_')
3742                 start++;
3743             if (*start == '.' && isDIGIT(start[1])) {
3744                 s = scan_num(s, &yylval);
3745                 TERM(THING);
3746             }
3747             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3748             else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) {
3749                 char c = *start;
3750                 GV *gv;
3751                 *start = '\0';
3752                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3753                 *start = c;
3754                 if (!gv) {
3755                     s = scan_num(s, &yylval);
3756                     TERM(THING);
3757                 }
3758             }
3759         }
3760         goto keylookup;
3761     case 'x':
3762         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3763             s++;
3764             Mop(OP_REPEAT);
3765         }
3766         goto keylookup;
3767
3768     case '_':
3769     case 'a': case 'A':
3770     case 'b': case 'B':
3771     case 'c': case 'C':
3772     case 'd': case 'D':
3773     case 'e': case 'E':
3774     case 'f': case 'F':
3775     case 'g': case 'G':
3776     case 'h': case 'H':
3777     case 'i': case 'I':
3778     case 'j': case 'J':
3779     case 'k': case 'K':
3780     case 'l': case 'L':
3781     case 'm': case 'M':
3782     case 'n': case 'N':
3783     case 'o': case 'O':
3784     case 'p': case 'P':
3785     case 'q': case 'Q':
3786     case 'r': case 'R':
3787     case 's': case 'S':
3788     case 't': case 'T':
3789     case 'u': case 'U':
3790               case 'V':
3791     case 'w': case 'W':
3792               case 'X':
3793     case 'y': case 'Y':
3794     case 'z': case 'Z':
3795
3796       keylookup: {
3797         gv = Nullgv;
3798         gvp = 0;
3799
3800         PL_bufptr = s;
3801         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3802
3803         /* Some keywords can be followed by any delimiter, including ':' */
3804         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3805                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3806                              (PL_tokenbuf[0] == 'q' &&
3807                               strchr("qwxr", PL_tokenbuf[1])))));
3808
3809         /* x::* is just a word, unless x is "CORE" */
3810         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3811             goto just_a_word;
3812
3813         d = s;
3814         while (d < PL_bufend && isSPACE(*d))
3815                 d++;    /* no comments skipped here, or s### is misparsed */
3816
3817         /* Is this a label? */
3818         if (!tmp && PL_expect == XSTATE
3819               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3820             s = d + 1;
3821             yylval.pval = savepv(PL_tokenbuf);
3822             CLINE;
3823             TOKEN(LABEL);
3824         }
3825
3826         /* Check for keywords */
3827         tmp = keyword(PL_tokenbuf, len);
3828
3829         /* Is this a word before a => operator? */
3830         if (*d == '=' && d[1] == '>') {
3831             CLINE;
3832             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3833             yylval.opval->op_private = OPpCONST_BARE;
3834             if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3835               SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3836             TERM(WORD);
3837         }
3838
3839         if (tmp < 0) {                  /* second-class keyword? */
3840             GV *ogv = Nullgv;   /* override (winner) */
3841             GV *hgv = Nullgv;   /* hidden (loser) */
3842             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3843                 CV *cv;
3844                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3845                     (cv = GvCVu(gv)))
3846                 {
3847                     if (GvIMPORTED_CV(gv))
3848                         ogv = gv;
3849                     else if (! CvMETHOD(cv))
3850                         hgv = gv;
3851                 }
3852                 if (!ogv &&
3853                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3854                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3855                     GvCVu(gv) && GvIMPORTED_CV(gv))
3856                 {
3857                     ogv = gv;
3858                 }
3859             }
3860             if (ogv) {
3861                 tmp = 0;                /* overridden by import or by GLOBAL */
3862             }
3863             else if (gv && !gvp
3864                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3865                      && GvCVu(gv)
3866                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3867             {
3868                 tmp = 0;                /* any sub overrides "weak" keyword */
3869             }
3870             else {                      /* no override */
3871                 tmp = -tmp;
3872                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
3873                     Perl_warner(aTHX_ packWARN(WARN_MISC),
3874                             "dump() better written as CORE::dump()");
3875                 }
3876                 gv = Nullgv;
3877                 gvp = 0;
3878                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3879                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3880                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3881                         "Ambiguous call resolved as CORE::%s(), %s",
3882                          GvENAME(hgv), "qualify as such or use &");
3883             }
3884         }
3885
3886       reserved_word:
3887         switch (tmp) {
3888
3889         default:                        /* not a keyword */
3890           just_a_word: {
3891                 SV *sv;
3892                 int pkgname = 0;
3893                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3894
3895                 /* Get the rest if it looks like a package qualifier */
3896
3897                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3898                     STRLEN morelen;
3899                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3900                                   TRUE, &morelen);
3901                     if (!morelen)
3902                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3903                                 *s == '\'' ? "'" : "::");
3904                     len += morelen;
3905                     pkgname = 1;
3906                 }
3907
3908                 if (PL_expect == XOPERATOR) {
3909                     if (PL_bufptr == PL_linestart) {
3910                         CopLINE_dec(PL_curcop);
3911                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3912                         CopLINE_inc(PL_curcop);
3913                     }
3914                     else
3915                         no_op("Bareword",s);
3916                 }
3917
3918                 /* Look for a subroutine with this name in current package,
3919                    unless name is "Foo::", in which case Foo is a bearword
3920                    (and a package name). */
3921
3922                 if (len > 2 &&
3923                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3924                 {
3925                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3926                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
3927                             "Bareword \"%s\" refers to nonexistent package",
3928                              PL_tokenbuf);
3929                     len -= 2;
3930                     PL_tokenbuf[len] = '\0';
3931                     gv = Nullgv;
3932                     gvp = 0;
3933                 }
3934                 else {
3935                     len = 0;
3936                     if (!gv)
3937                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3938                 }
3939
3940                 /* if we saw a global override before, get the right name */
3941
3942                 if (gvp) {
3943                     sv = newSVpvn("CORE::GLOBAL::",14);
3944                     sv_catpv(sv,PL_tokenbuf);
3945                 }
3946                 else
3947                     sv = newSVpv(PL_tokenbuf,0);
3948
3949                 /* Presume this is going to be a bareword of some sort. */
3950
3951                 CLINE;
3952                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3953                 yylval.opval->op_private = OPpCONST_BARE;
3954                 /* UTF-8 package name? */
3955                 if (UTF && !IN_BYTES &&
3956                     is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
3957                     SvUTF8_on(sv);
3958
3959                 /* And if "Foo::", then that's what it certainly is. */
3960
3961                 if (len)
3962                     goto safe_bareword;
3963
3964                 /* See if it's the indirect object for a list operator. */
3965
3966                 if (PL_oldoldbufptr &&
3967                     PL_oldoldbufptr < PL_bufptr &&
3968                     (PL_oldoldbufptr == PL_last_lop
3969                      || PL_oldoldbufptr == PL_last_uni) &&
3970                     /* NO SKIPSPACE BEFORE HERE! */
3971                     (PL_expect == XREF ||
3972                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3973                 {
3974                     bool immediate_paren = *s == '(';
3975
3976                     /* (Now we can afford to cross potential line boundary.) */
3977                     s = skipspace(s);
3978
3979                     /* Two barewords in a row may indicate method call. */
3980
3981                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
3982                         return tmp;
3983
3984                     /* If not a declared subroutine, it's an indirect object. */
3985                     /* (But it's an indir obj regardless for sort.) */
3986
3987                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
3988                          ((!gv || !GvCVu(gv)) &&
3989                         (PL_last_lop_op != OP_MAPSTART &&
3990                          PL_last_lop_op != OP_GREPSTART))))
3991                     {
3992                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3993                         goto bareword;
3994                     }
3995                 }
3996
3997                 PL_expect = XOPERATOR;
3998                 s = skipspace(s);
3999
4000                 /* Is this a word before a => operator? */
4001                 if (*s == '=' && s[1] == '>' && !pkgname) {
4002                     CLINE;
4003                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4004                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4005                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4006                     TERM(WORD);
4007                 }
4008
4009                 /* If followed by a paren, it's certainly a subroutine. */
4010                 if (*s == '(') {
4011                     CLINE;
4012                     if (gv && GvCVu(gv)) {
4013                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4014                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4015                             s = d + 1;
4016                             goto its_constant;
4017                         }
4018                     }
4019                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4020                     PL_expect = XOPERATOR;
4021                     force_next(WORD);
4022                     yylval.ival = 0;
4023                     TOKEN('&');
4024                 }
4025
4026                 /* If followed by var or block, call it a method (unless sub) */
4027
4028                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4029                     PL_last_lop = PL_oldbufptr;
4030                     PL_last_lop_op = OP_METHOD;
4031                     PREBLOCK(METHOD);
4032                 }
4033
4034                 /* If followed by a bareword, see if it looks like indir obj. */
4035
4036                 if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp = intuit_method(s,gv)))
4037                     return tmp;
4038
4039                 /* Not a method, so call it a subroutine (if defined) */
4040
4041                 if (gv && GvCVu(gv)) {
4042                     CV* cv;
4043                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4044                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4045                                 "Ambiguous use of -%s resolved as -&%s()",
4046                                 PL_tokenbuf, PL_tokenbuf);
4047                     /* Check for a constant sub */
4048                     cv = GvCV(gv);
4049                     if ((sv = cv_const_sv(cv))) {
4050                   its_constant:
4051                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4052                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4053                         yylval.opval->op_private = 0;
4054                         TOKEN(WORD);
4055                     }
4056
4057                     /* Resolve to GV now. */
4058                     op_free(yylval.opval);
4059                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4060                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4061                     PL_last_lop = PL_oldbufptr;
4062                     PL_last_lop_op = OP_ENTERSUB;
4063                     /* Is there a prototype? */
4064                     if (SvPOK(cv)) {
4065                         STRLEN len;
4066                         char *proto = SvPV((SV*)cv, len);
4067                         if (!len)
4068                             TERM(FUNC0SUB);
4069                         if (strEQ(proto, "$"))
4070                             OPERATOR(UNIOPSUB);
4071                         if (*proto == '&' && *s == '{') {
4072                             sv_setpv(PL_subname, PL_curstash ? 
4073                                         "__ANON__" : "__ANON__::__ANON__");
4074                             PREBLOCK(LSTOPSUB);
4075                         }
4076                     }
4077                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4078                     PL_expect = XTERM;
4079                     force_next(WORD);
4080                     TOKEN(NOAMP);
4081                 }
4082
4083                 /* Call it a bare word */
4084
4085                 if (PL_hints & HINT_STRICT_SUBS)
4086                     yylval.opval->op_private |= OPpCONST_STRICT;
4087                 else {
4088                 bareword:
4089                     if (ckWARN(WARN_RESERVED)) {
4090                         if (lastchar != '-') {
4091                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4092                             if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4093                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4094                                        PL_tokenbuf);
4095                         }
4096                     }
4097                 }
4098
4099             safe_bareword:
4100                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4101                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4102                         "Operator or semicolon missing before %c%s",
4103                         lastchar, PL_tokenbuf);
4104                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4105                         "Ambiguous use of %c resolved as operator %c",
4106                         lastchar, lastchar);
4107                 }
4108                 TOKEN(WORD);
4109             }
4110
4111         case KEY___FILE__:
4112             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4113                                         newSVpv(CopFILE(PL_curcop),0));
4114             TERM(THING);
4115
4116         case KEY___LINE__:
4117             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4118                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4119             TERM(THING);
4120
4121         case KEY___PACKAGE__:
4122             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4123                                         (PL_curstash
4124                                          ? newSVsv(PL_curstname)
4125                                          : &PL_sv_undef));
4126             TERM(THING);
4127
4128         case KEY___DATA__:
4129         case KEY___END__: {
4130             GV *gv;
4131
4132             /*SUPPRESS 560*/
4133             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4134                 char *pname = "main";
4135                 if (PL_tokenbuf[2] == 'D')
4136                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4137                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4138                 GvMULTI_on(gv);
4139                 if (!GvIO(gv))
4140                     GvIOp(gv) = newIO();
4141                 IoIFP(GvIOp(gv)) = PL_rsfp;
4142 #if defined(HAS_FCNTL) && defined(F_SETFD)
4143                 {
4144                     int fd = PerlIO_fileno(PL_rsfp);
4145                     fcntl(fd,F_SETFD,fd >= 3);
4146                 }
4147 #endif
4148                 /* Mark this internal pseudo-handle as clean */
4149                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4150                 if (PL_preprocess)
4151                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4152                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4153                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4154                 else
4155                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4156 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4157                 /* if the script was opened in binmode, we need to revert
4158                  * it to text mode for compatibility; but only iff it has CRs
4159                  * XXX this is a questionable hack at best. */
4160                 if (PL_bufend-PL_bufptr > 2
4161                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4162                 {
4163                     Off_t loc = 0;
4164                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4165                         loc = PerlIO_tell(PL_rsfp);
4166                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
4167                     }
4168 #ifdef NETWARE
4169                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4170 #else
4171                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4172 #endif  /* NETWARE */
4173 #ifdef PERLIO_IS_STDIO /* really? */
4174 #  if defined(__BORLANDC__)
4175                         /* XXX see note in do_binmode() */
4176                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4177 #  endif
4178 #endif
4179                         if (loc > 0)
4180                             PerlIO_seek(PL_rsfp, loc, 0);
4181                     }
4182                 }
4183 #endif
4184 #ifdef PERLIO_LAYERS
4185                 if (UTF && !IN_BYTES)
4186                     PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4187 #endif
4188                 PL_rsfp = Nullfp;
4189             }
4190             goto fake_eof;
4191         }
4192
4193         case KEY_AUTOLOAD:
4194         case KEY_DESTROY:
4195         case KEY_BEGIN:
4196         case KEY_CHECK:
4197         case KEY_INIT:
4198         case KEY_END:
4199             if (PL_expect == XSTATE) {
4200                 s = PL_bufptr;
4201                 goto really_sub;
4202             }
4203             goto just_a_word;
4204
4205         case KEY_CORE:
4206             if (*s == ':' && s[1] == ':') {
4207                 s += 2;
4208                 d = s;
4209                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4210                 if (!(tmp = keyword(PL_tokenbuf, len)))
4211                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4212                 if (tmp < 0)
4213                     tmp = -tmp;
4214                 goto reserved_word;
4215             }
4216             goto just_a_word;
4217
4218         case KEY_abs:
4219             UNI(OP_ABS);
4220
4221         case KEY_alarm:
4222             UNI(OP_ALARM);
4223
4224         case KEY_accept:
4225             LOP(OP_ACCEPT,XTERM);
4226
4227         case KEY_and:
4228             OPERATOR(ANDOP);
4229
4230         case KEY_atan2:
4231             LOP(OP_ATAN2,XTERM);
4232
4233         case KEY_bind:
4234             LOP(OP_BIND,XTERM);
4235
4236         case KEY_binmode:
4237             LOP(OP_BINMODE,XTERM);
4238
4239         case KEY_bless:
4240             LOP(OP_BLESS,XTERM);
4241
4242         case KEY_chop:
4243             UNI(OP_CHOP);
4244
4245         case KEY_continue:
4246             PREBLOCK(CONTINUE);
4247
4248         case KEY_chdir:
4249             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
4250             UNI(OP_CHDIR);
4251
4252         case KEY_close:
4253             UNI(OP_CLOSE);
4254
4255         case KEY_closedir:
4256             UNI(OP_CLOSEDIR);
4257
4258         case KEY_cmp:
4259             Eop(OP_SCMP);
4260
4261         case KEY_caller:
4262             UNI(OP_CALLER);
4263
4264         case KEY_crypt:
4265 #ifdef FCRYPT
4266             if (!PL_cryptseen) {
4267                 PL_cryptseen = TRUE;
4268                 init_des();
4269             }
4270 #endif
4271             LOP(OP_CRYPT,XTERM);
4272
4273         case KEY_chmod:
4274             LOP(OP_CHMOD,XTERM);
4275
4276         case KEY_chown:
4277             LOP(OP_CHOWN,XTERM);
4278
4279         case KEY_connect:
4280             LOP(OP_CONNECT,XTERM);
4281
4282         case KEY_chr:
4283             UNI(OP_CHR);
4284
4285         case KEY_cos:
4286             UNI(OP_COS);
4287
4288         case KEY_chroot:
4289             UNI(OP_CHROOT);
4290
4291         case KEY_do:
4292             s = skipspace(s);
4293             if (*s == '{')
4294                 PRETERMBLOCK(DO);
4295             if (*s != '\'')
4296                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4297             OPERATOR(DO);
4298
4299         case KEY_die:
4300             PL_hints |= HINT_BLOCK_SCOPE;
4301             LOP(OP_DIE,XTERM);
4302
4303         case KEY_defined:
4304             UNI(OP_DEFINED);
4305
4306         case KEY_delete:
4307             UNI(OP_DELETE);
4308
4309         case KEY_dbmopen:
4310             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4311             LOP(OP_DBMOPEN,XTERM);
4312
4313         case KEY_dbmclose:
4314             UNI(OP_DBMCLOSE);
4315
4316         case KEY_dump:
4317             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4318             LOOPX(OP_DUMP);
4319
4320         case KEY_else:
4321             PREBLOCK(ELSE);
4322
4323         case KEY_elsif:
4324             yylval.ival = CopLINE(PL_curcop);
4325             OPERATOR(ELSIF);
4326
4327         case KEY_eq:
4328             Eop(OP_SEQ);
4329
4330         case KEY_exists:
4331             UNI(OP_EXISTS);
4332         
4333         case KEY_exit:
4334             UNI(OP_EXIT);
4335
4336         case KEY_eval:
4337             s = skipspace(s);
4338             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4339             UNIBRACK(OP_ENTEREVAL);
4340
4341         case KEY_eof:
4342             UNI(OP_EOF);
4343
4344         case KEY_err:
4345             OPERATOR(DOROP);
4346
4347         case KEY_exp:
4348             UNI(OP_EXP);
4349
4350         case KEY_each:
4351             UNI(OP_EACH);
4352
4353         case KEY_exec:
4354             set_csh();
4355             LOP(OP_EXEC,XREF);
4356
4357         case KEY_endhostent:
4358             FUN0(OP_EHOSTENT);
4359
4360         case KEY_endnetent:
4361             FUN0(OP_ENETENT);
4362
4363         case KEY_endservent:
4364             FUN0(OP_ESERVENT);
4365
4366         case KEY_endprotoent:
4367             FUN0(OP_EPROTOENT);
4368
4369         case KEY_endpwent:
4370             FUN0(OP_EPWENT);
4371
4372         case KEY_endgrent:
4373             FUN0(OP_EGRENT);
4374
4375         case KEY_for:
4376         case KEY_foreach:
4377             yylval.ival = CopLINE(PL_curcop);
4378             s = skipspace(s);
4379             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4380                 char *p = s;
4381                 if ((PL_bufend - p) >= 3 &&
4382                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4383                     p += 2;
4384                 else if ((PL_bufend - p) >= 4 &&
4385                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4386                     p += 3;
4387                 p = skipspace(p);
4388                 if (isIDFIRST_lazy_if(p,UTF)) {
4389                     p = scan_ident(p, PL_bufend,
4390                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4391                     p = skipspace(p);
4392                 }
4393                 if (*p != '$')
4394                     Perl_croak(aTHX_ "Missing $ on loop variable");
4395             }
4396             OPERATOR(FOR);
4397
4398         case KEY_formline:
4399             LOP(OP_FORMLINE,XTERM);
4400
4401         case KEY_fork:
4402             FUN0(OP_FORK);
4403
4404         case KEY_fcntl:
4405             LOP(OP_FCNTL,XTERM);
4406
4407         case KEY_fileno:
4408             UNI(OP_FILENO);
4409
4410         case KEY_flock:
4411             LOP(OP_FLOCK,XTERM);
4412
4413         case KEY_gt:
4414             Rop(OP_SGT);
4415
4416         case KEY_ge:
4417             Rop(OP_SGE);
4418
4419         case KEY_grep:
4420             LOP(OP_GREPSTART, XREF);
4421
4422         case KEY_goto:
4423             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4424             LOOPX(OP_GOTO);
4425
4426         case KEY_gmtime:
4427             UNI(OP_GMTIME);
4428
4429         case KEY_getc:
4430             UNI(OP_GETC);
4431
4432         case KEY_getppid:
4433             FUN0(OP_GETPPID);
4434
4435         case KEY_getpgrp:
4436             UNI(OP_GETPGRP);
4437
4438         case KEY_getpriority:
4439             LOP(OP_GETPRIORITY,XTERM);
4440
4441         case KEY_getprotobyname:
4442             UNI(OP_GPBYNAME);
4443
4444         case KEY_getprotobynumber:
4445             LOP(OP_GPBYNUMBER,XTERM);
4446
4447         case KEY_getprotoent:
4448             FUN0(OP_GPROTOENT);
4449
4450         case KEY_getpwent:
4451             FUN0(OP_GPWENT);
4452
4453         case KEY_getpwnam:
4454             UNI(OP_GPWNAM);
4455
4456         case KEY_getpwuid:
4457             UNI(OP_GPWUID);
4458
4459         case KEY_getpeername:
4460             UNI(OP_GETPEERNAME);
4461
4462         case KEY_gethostbyname:
4463             UNI(OP_GHBYNAME);
4464
4465         case KEY_gethostbyaddr:
4466             LOP(OP_GHBYADDR,XTERM);
4467
4468         case KEY_gethostent:
4469             FUN0(OP_GHOSTENT);
4470
4471         case KEY_getnetbyname:
4472             UNI(OP_GNBYNAME);
4473
4474         case KEY_getnetbyaddr:
4475             LOP(OP_GNBYADDR,XTERM);
4476
4477         case KEY_getnetent:
4478             FUN0(OP_GNETENT);
4479
4480         case KEY_getservbyname:
4481             LOP(OP_GSBYNAME,XTERM);
4482
4483         case KEY_getservbyport:
4484             LOP(OP_GSBYPORT,XTERM);
4485
4486         case KEY_getservent:
4487             FUN0(OP_GSERVENT);
4488
4489         case KEY_getsockname:
4490             UNI(OP_GETSOCKNAME);
4491
4492         case KEY_getsockopt:
4493             LOP(OP_GSOCKOPT,XTERM);
4494
4495         case KEY_getgrent:
4496             FUN0(OP_GGRENT);
4497
4498         case KEY_getgrnam:
4499             UNI(OP_GGRNAM);
4500
4501         case KEY_getgrgid:
4502             UNI(OP_GGRGID);
4503
4504         case KEY_getlogin:
4505             FUN0(OP_GETLOGIN);
4506
4507         case KEY_glob:
4508             set_csh();
4509             LOP(OP_GLOB,XTERM);
4510
4511         case KEY_hex:
4512             UNI(OP_HEX);
4513
4514         case KEY_if:
4515             yylval.ival = CopLINE(PL_curcop);
4516             OPERATOR(IF);
4517
4518         case KEY_index:
4519             LOP(OP_INDEX,XTERM);
4520
4521         case KEY_int:
4522             UNI(OP_INT);
4523
4524         case KEY_ioctl:
4525             LOP(OP_IOCTL,XTERM);
4526
4527         case KEY_join:
4528             LOP(OP_JOIN,XTERM);
4529
4530         case KEY_keys:
4531             UNI(OP_KEYS);
4532
4533         case KEY_kill:
4534             LOP(OP_KILL,XTERM);
4535
4536         case KEY_last:
4537             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4538             LOOPX(OP_LAST);
4539         
4540         case KEY_lc:
4541             UNI(OP_LC);
4542
4543         case KEY_lcfirst:
4544             UNI(OP_LCFIRST);
4545
4546         case KEY_local:
4547             yylval.ival = 0;
4548             OPERATOR(LOCAL);
4549
4550         case KEY_length:
4551             UNI(OP_LENGTH);
4552
4553         case KEY_lt:
4554             Rop(OP_SLT);
4555
4556         case KEY_le:
4557             Rop(OP_SLE);
4558
4559         case KEY_localtime:
4560             UNI(OP_LOCALTIME);
4561
4562         case KEY_log:
4563             UNI(OP_LOG);
4564
4565         case KEY_link:
4566             LOP(OP_LINK,XTERM);
4567
4568         case KEY_listen:
4569             LOP(OP_LISTEN,XTERM);
4570
4571         case KEY_lock:
4572             UNI(OP_LOCK);
4573
4574         case KEY_lstat:
4575             UNI(OP_LSTAT);
4576
4577         case KEY_m:
4578             s = scan_pat(s,OP_MATCH);
4579             TERM(sublex_start());
4580
4581         case KEY_map:
4582             LOP(OP_MAPSTART, XREF);
4583
4584         case KEY_mkdir:
4585             LOP(OP_MKDIR,XTERM);
4586
4587         case KEY_msgctl:
4588             LOP(OP_MSGCTL,XTERM);
4589
4590         case KEY_msgget:
4591             LOP(OP_MSGGET,XTERM);
4592
4593         case KEY_msgrcv:
4594             LOP(OP_MSGRCV,XTERM);
4595
4596         case KEY_msgsnd:
4597             LOP(OP_MSGSND,XTERM);
4598
4599         case KEY_our:
4600         case KEY_my:
4601             PL_in_my = tmp;
4602             s = skipspace(s);
4603             if (isIDFIRST_lazy_if(s,UTF)) {
4604                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4605                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4606                     goto really_sub;
4607                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4608                 if (!PL_in_my_stash) {
4609                     char tmpbuf[1024];
4610                     PL_bufptr = s;
4611                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4612                     yyerror(tmpbuf);
4613                 }
4614             }
4615             yylval.ival = 1;
4616             OPERATOR(MY);
4617
4618         case KEY_next:
4619             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4620             LOOPX(OP_NEXT);
4621
4622         case KEY_ne:
4623             Eop(OP_SNE);
4624
4625         case KEY_no:
4626             if (PL_expect != XSTATE)
4627                 yyerror("\"no\" not allowed in expression");
4628             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4629             s = force_version(s, FALSE);
4630             yylval.ival = 0;
4631             OPERATOR(USE);
4632
4633         case KEY_not:
4634             if (*s == '(' || (s = skipspace(s), *s == '('))
4635                 FUN1(OP_NOT);
4636             else
4637                 OPERATOR(NOTOP);
4638
4639         case KEY_open:
4640             s = skipspace(s);
4641             if (isIDFIRST_lazy_if(s,UTF)) {
4642                 char *t;
4643                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4644                 t = skipspace(d);
4645                 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE))
4646                     Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4647                            "Precedence problem: open %.*s should be open(%.*s)",
4648                             d-s,s, d-s,s);
4649             }
4650             LOP(OP_OPEN,XTERM);
4651
4652         case KEY_or:
4653             yylval.ival = OP_OR;
4654             OPERATOR(OROP);
4655
4656         case KEY_ord:
4657             UNI(OP_ORD);
4658
4659         case KEY_oct:
4660             UNI(OP_OCT);
4661
4662         case KEY_opendir:
4663             LOP(OP_OPEN_DIR,XTERM);
4664
4665         case KEY_print:
4666             checkcomma(s,PL_tokenbuf,"filehandle");
4667             LOP(OP_PRINT,XREF);
4668
4669         case KEY_printf:
4670             checkcomma(s,PL_tokenbuf,"filehandle");
4671             LOP(OP_PRTF,XREF);
4672
4673         case KEY_prototype:
4674             UNI(OP_PROTOTYPE);
4675
4676         case KEY_push:
4677             LOP(OP_PUSH,XTERM);
4678
4679         case KEY_pop:
4680             UNI(OP_POP);
4681
4682         case KEY_pos:
4683             UNI(OP_POS);
4684         
4685         case KEY_pack:
4686             LOP(OP_PACK,XTERM);
4687
4688         case KEY_package:
4689             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4690             OPERATOR(PACKAGE);
4691
4692         case KEY_pipe:
4693             LOP(OP_PIPE_OP,XTERM);
4694
4695         case KEY_q:
4696             s = scan_str(s,FALSE,FALSE);
4697             if (!s)
4698                 missingterm((char*)0);
4699             yylval.ival = OP_CONST;
4700             TERM(sublex_start());
4701
4702         case KEY_quotemeta:
4703             UNI(OP_QUOTEMETA);
4704
4705         case KEY_qw:
4706             s = scan_str(s,FALSE,FALSE);
4707             if (!s)
4708                 missingterm((char*)0);
4709             force_next(')');
4710             if (SvCUR(PL_lex_stuff)) {
4711                 OP *words = Nullop;
4712                 int warned = 0;
4713                 d = SvPV_force(PL_lex_stuff, len);
4714                 while (len) {
4715                     SV *sv;
4716                     for (; isSPACE(*d) && len; --len, ++d) ;
4717                     if (len) {
4718                         char *b = d;
4719                         if (!warned && ckWARN(WARN_QW)) {
4720                             for (; !isSPACE(*d) && len; --len, ++d) {
4721                                 if (*d == ',') {
4722                                     Perl_warner(aTHX_ packWARN(WARN_QW),
4723                                         "Possible attempt to separate words with commas");
4724                                     ++warned;
4725                                 }
4726                                 else if (*d == '#') {
4727                                     Perl_warner(aTHX_ packWARN(WARN_QW),
4728                                         "Possible attempt to put comments in qw() list");
4729                                     ++warned;
4730                                 }
4731                             }
4732                         }
4733                         else {
4734                             for (; !isSPACE(*d) && len; --len, ++d) ;
4735                         }
4736                         sv = newSVpvn(b, d-b);
4737                         if (DO_UTF8(PL_lex_stuff))
4738                             SvUTF8_on(sv);
4739                         words = append_elem(OP_LIST, words,
4740                                             newSVOP(OP_CONST, 0, tokeq(sv)));
4741                     }
4742                 }
4743                 if (words) {
4744                     PL_nextval[PL_nexttoke].opval = words;
4745                     force_next(THING);
4746                 }
4747             }
4748             if (PL_lex_stuff) {
4749                 SvREFCNT_dec(PL_lex_stuff);
4750                 PL_lex_stuff = Nullsv;
4751             }
4752             PL_expect = XTERM;
4753             TOKEN('(');
4754
4755         case KEY_qq:
4756             s = scan_str(s,FALSE,FALSE);
4757             if (!s)
4758                 missingterm((char*)0);
4759             yylval.ival = OP_STRINGIFY;
4760             if (SvIVX(PL_lex_stuff) == '\'')
4761                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
4762             TERM(sublex_start());
4763
4764         case KEY_qr:
4765             s = scan_pat(s,OP_QR);
4766             TERM(sublex_start());
4767
4768         case KEY_qx:
4769             s = scan_str(s,FALSE,FALSE);
4770             if (!s)
4771                 missingterm((char*)0);
4772             yylval.ival = OP_BACKTICK;
4773             set_csh();
4774             TERM(sublex_start());
4775
4776         case KEY_return:
4777             OLDLOP(OP_RETURN);
4778
4779         case KEY_require:
4780             s = skipspace(s);
4781             if (isDIGIT(*s)) {
4782                 s = force_version(s, FALSE);
4783             }
4784             else if (*s != 'v' || !isDIGIT(s[1])
4785                     || (s = force_version(s, TRUE), *s == 'v'))
4786             {
4787                 *PL_tokenbuf = '\0';
4788                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4789                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4790                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4791                 else if (*s == '<')
4792                     yyerror("<> should be quotes");
4793             }
4794             UNI(OP_REQUIRE);
4795
4796         case KEY_reset:
4797             UNI(OP_RESET);
4798
4799         case KEY_redo:
4800             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4801             LOOPX(OP_REDO);
4802
4803         case KEY_rename:
4804             LOP(OP_RENAME,XTERM);
4805
4806         case KEY_rand:
4807             UNI(OP_RAND);
4808
4809         case KEY_rmdir:
4810             UNI(OP_RMDIR);
4811
4812         case KEY_rindex:
4813             LOP(OP_RINDEX,XTERM);
4814
4815         case KEY_read:
4816             LOP(OP_READ,XTERM);
4817
4818         case KEY_readdir:
4819             UNI(OP_READDIR);
4820
4821         case KEY_readline:
4822             set_csh();
4823             UNI(OP_READLINE);
4824
4825         case KEY_readpipe:
4826             set_csh();
4827             UNI(OP_BACKTICK);
4828
4829         case KEY_rewinddir:
4830             UNI(OP_REWINDDIR);
4831
4832         case KEY_recv:
4833             LOP(OP_RECV,XTERM);
4834
4835         case KEY_reverse:
4836             LOP(OP_REVERSE,XTERM);
4837
4838         case KEY_readlink:
4839             UNI(OP_READLINK);
4840
4841         case KEY_ref:
4842             UNI(OP_REF);
4843
4844         case KEY_s:
4845             s = scan_subst(s);
4846             if (yylval.opval)
4847                 TERM(sublex_start());
4848             else
4849                 TOKEN(1);       /* force error */
4850
4851         case KEY_chomp:
4852             UNI(OP_CHOMP);
4853         
4854         case KEY_scalar:
4855             UNI(OP_SCALAR);
4856
4857         case KEY_select:
4858             LOP(OP_SELECT,XTERM);
4859
4860         case KEY_seek:
4861             LOP(OP_SEEK,XTERM);
4862
4863         case KEY_semctl:
4864             LOP(OP_SEMCTL,XTERM);
4865
4866         case KEY_semget:
4867             LOP(OP_SEMGET,XTERM);
4868
4869         case KEY_semop:
4870             LOP(OP_SEMOP,XTERM);
4871
4872         case KEY_send:
4873             LOP(OP_SEND,XTERM);
4874
4875         case KEY_setpgrp:
4876             LOP(OP_SETPGRP,XTERM);
4877
4878         case KEY_setpriority:
4879             LOP(OP_SETPRIORITY,XTERM);
4880
4881         case KEY_sethostent:
4882             UNI(OP_SHOSTENT);
4883
4884         case KEY_setnetent:
4885             UNI(OP_SNETENT);
4886
4887         case KEY_setservent:
4888             UNI(OP_SSERVENT);
4889
4890         case KEY_setprotoent:
4891             UNI(OP_SPROTOENT);
4892
4893         case KEY_setpwent:
4894             FUN0(OP_SPWENT);
4895
4896         case KEY_setgrent:
4897             FUN0(OP_SGRENT);
4898
4899         case KEY_seekdir:
4900             LOP(OP_SEEKDIR,XTERM);
4901
4902         case KEY_setsockopt:
4903             LOP(OP_SSOCKOPT,XTERM);
4904
4905         case KEY_shift:
4906             UNI(OP_SHIFT);
4907
4908         case KEY_shmctl:
4909             LOP(OP_SHMCTL,XTERM);
4910
4911         case KEY_shmget:
4912             LOP(OP_SHMGET,XTERM);
4913
4914         case KEY_shmread:
4915             LOP(OP_SHMREAD,XTERM);
4916
4917         case KEY_shmwrite:
4918             LOP(OP_SHMWRITE,XTERM);
4919
4920         case KEY_shutdown:
4921             LOP(OP_SHUTDOWN,XTERM);
4922
4923         case KEY_sin:
4924             UNI(OP_SIN);
4925
4926         case KEY_sleep:
4927             UNI(OP_SLEEP);
4928
4929         case KEY_socket:
4930             LOP(OP_SOCKET,XTERM);
4931
4932         case KEY_socketpair:
4933             LOP(OP_SOCKPAIR,XTERM);
4934
4935         case KEY_sort:
4936             checkcomma(s,PL_tokenbuf,"subroutine name");
4937             s = skipspace(s);
4938             if (*s == ';' || *s == ')')         /* probably a close */
4939                 Perl_croak(aTHX_ "sort is now a reserved word");
4940             PL_expect = XTERM;
4941             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4942             LOP(OP_SORT,XREF);
4943
4944         case KEY_split:
4945             LOP(OP_SPLIT,XTERM);
4946
4947         case KEY_sprintf:
4948             LOP(OP_SPRINTF,XTERM);
4949
4950         case KEY_splice:
4951             LOP(OP_SPLICE,XTERM);
4952
4953         case KEY_sqrt:
4954             UNI(OP_SQRT);
4955
4956         case KEY_srand:
4957             UNI(OP_SRAND);
4958
4959         case KEY_stat:
4960             UNI(OP_STAT);
4961
4962         case KEY_study:
4963             UNI(OP_STUDY);
4964
4965         case KEY_substr:
4966             LOP(OP_SUBSTR,XTERM);
4967
4968         case KEY_format:
4969         case KEY_sub:
4970           really_sub:
4971             {
4972                 char tmpbuf[sizeof PL_tokenbuf];
4973                 SSize_t tboffset = 0;
4974                 expectation attrful;
4975                 bool have_name, have_proto, bad_proto;
4976                 int key = tmp;
4977
4978                 s = skipspace(s);
4979
4980                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
4981                     (*s == ':' && s[1] == ':'))
4982                 {
4983                     PL_expect = XBLOCK;
4984                     attrful = XATTRBLOCK;
4985                     /* remember buffer pos'n for later force_word */
4986                     tboffset = s - PL_oldbufptr;
4987                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4988                     if (strchr(tmpbuf, ':'))
4989                         sv_setpv(PL_subname, tmpbuf);
4990                     else {
4991                         sv_setsv(PL_subname,PL_curstname);
4992                         sv_catpvn(PL_subname,"::",2);
4993                         sv_catpvn(PL_subname,tmpbuf,len);
4994                     }
4995                     s = skipspace(d);
4996                     have_name = TRUE;
4997                 }
4998                 else {
4999                     if (key == KEY_my)
5000                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
5001                     PL_expect = XTERMBLOCK;
5002                     attrful = XATTRTERM;
5003                     sv_setpv(PL_subname,"?");
5004                     have_name = FALSE;
5005                 }
5006
5007                 if (key == KEY_format) {
5008                     if (*s == '=')
5009                         PL_lex_formbrack = PL_lex_brackets + 1;
5010                     if (have_name)
5011                         (void) force_word(PL_oldbufptr + tboffset, WORD,
5012                                           FALSE, TRUE, TRUE);
5013                     OPERATOR(FORMAT);
5014                 }
5015
5016                 /* Look for a prototype */
5017                 if (*s == '(') {
5018                     char *p;
5019
5020                     s = scan_str(s,FALSE,FALSE);
5021                     if (!s)
5022                         Perl_croak(aTHX_ "Prototype not terminated");
5023                     /* strip spaces and check for bad characters */
5024                     d = SvPVX(PL_lex_stuff);
5025                     tmp = 0;
5026                     bad_proto = FALSE;
5027                     for (p = d; *p; ++p) {
5028                         if (!isSPACE(*p)) {
5029                             d[tmp++] = *p;
5030                             if (!strchr("$@%*;[]&\\", *p))
5031                                 bad_proto = TRUE;
5032                         }
5033                     }
5034                     d[tmp] = '\0';
5035                     if (bad_proto && ckWARN(WARN_SYNTAX))
5036                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5037                                     "Illegal character in prototype for %s : %s",
5038                                     SvPVX(PL_subname), d);
5039                     SvCUR(PL_lex_stuff) = tmp;
5040                     have_proto = TRUE;
5041
5042                     s = skipspace(s);
5043                 }
5044                 else
5045                     have_proto = FALSE;
5046
5047                 if (*s == ':' && s[1] != ':')
5048                     PL_expect = attrful;
5049
5050                 if (have_proto) {
5051                     PL_nextval[PL_nexttoke].opval =
5052                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5053                     PL_lex_stuff = Nullsv;
5054                     force_next(THING);
5055                 }
5056                 if (!have_name) {
5057                     sv_setpv(PL_subname,
5058                         PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5059                     TOKEN(ANONSUB);
5060                 }
5061                 (void) force_word(PL_oldbufptr + tboffset, WORD,
5062                                   FALSE, TRUE, TRUE);
5063                 if (key == KEY_my)
5064                     TOKEN(MYSUB);
5065                 TOKEN(SUB);
5066             }
5067
5068         case KEY_system:
5069             set_csh();
5070             LOP(OP_SYSTEM,XREF);
5071
5072         case KEY_symlink:
5073             LOP(OP_SYMLINK,XTERM);
5074
5075         case KEY_syscall:
5076             LOP(OP_SYSCALL,XTERM);
5077
5078         case KEY_sysopen:
5079             LOP(OP_SYSOPEN,XTERM);
5080
5081         case KEY_sysseek:
5082             LOP(OP_SYSSEEK,XTERM);
5083
5084         case KEY_sysread:
5085             LOP(OP_SYSREAD,XTERM);
5086
5087         case KEY_syswrite:
5088             LOP(OP_SYSWRITE,XTERM);
5089
5090         case KEY_tr:
5091             s = scan_trans(s);
5092             TERM(sublex_start());
5093
5094         case KEY_tell:
5095             UNI(OP_TELL);
5096
5097         case KEY_telldir:
5098             UNI(OP_TELLDIR);
5099
5100         case KEY_tie:
5101             LOP(OP_TIE,XTERM);
5102
5103         case KEY_tied:
5104             UNI(OP_TIED);
5105
5106         case KEY_time:
5107             FUN0(OP_TIME);
5108
5109         case KEY_times:
5110             FUN0(OP_TMS);
5111
5112         case KEY_truncate:
5113             LOP(OP_TRUNCATE,XTERM);
5114
5115         case KEY_uc:
5116             UNI(OP_UC);
5117
5118         case KEY_ucfirst:
5119             UNI(OP_UCFIRST);
5120
5121         case KEY_untie:
5122             UNI(OP_UNTIE);
5123
5124         case KEY_until:
5125             yylval.ival = CopLINE(PL_curcop);
5126             OPERATOR(UNTIL);
5127
5128         case KEY_unless:
5129             yylval.ival = CopLINE(PL_curcop);
5130             OPERATOR(UNLESS);
5131
5132         case KEY_unlink:
5133             LOP(OP_UNLINK,XTERM);
5134
5135         case KEY_undef:
5136             UNI(OP_UNDEF);
5137
5138         case KEY_unpack:
5139             LOP(OP_UNPACK,XTERM);
5140
5141         case KEY_utime:
5142             LOP(OP_UTIME,XTERM);
5143
5144         case KEY_umask:
5145             UNI(OP_UMASK);
5146
5147         case KEY_unshift:
5148             LOP(OP_UNSHIFT,XTERM);
5149
5150         case KEY_use:
5151             if (PL_expect != XSTATE)
5152                 yyerror("\"use\" not allowed in expression");
5153             s = skipspace(s);
5154             if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5155                 s = force_version(s, TRUE);
5156                 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5157                     PL_nextval[PL_nexttoke].opval = Nullop;
5158                     force_next(WORD);
5159                 }
5160                 else if (*s == 'v') {
5161                     s = force_word(s,WORD,FALSE,TRUE,FALSE);
5162                     s = force_version(s, FALSE);
5163                 }
5164             }
5165             else {
5166                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5167                 s = force_version(s, FALSE);
5168             }
5169             yylval.ival = 1;
5170             OPERATOR(USE);
5171
5172         case KEY_values:
5173             UNI(OP_VALUES);
5174
5175         case KEY_vec:
5176             LOP(OP_VEC,XTERM);
5177
5178         case KEY_while:
5179             yylval.ival = CopLINE(PL_curcop);
5180             OPERATOR(WHILE);
5181
5182         case KEY_warn:
5183             PL_hints |= HINT_BLOCK_SCOPE;
5184             LOP(OP_WARN,XTERM);
5185
5186         case KEY_wait:
5187             FUN0(OP_WAIT);
5188
5189         case KEY_waitpid:
5190             LOP(OP_WAITPID,XTERM);
5191
5192         case KEY_wantarray:
5193             FUN0(OP_WANTARRAY);
5194
5195         case KEY_write:
5196 #ifdef EBCDIC
5197         {
5198             char ctl_l[2];
5199             ctl_l[0] = toCTRL('L');
5200             ctl_l[1] = '\0';
5201             gv_fetchpv(ctl_l,TRUE, SVt_PV);
5202         }
5203 #else
5204             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
5205 #endif
5206             UNI(OP_ENTERWRITE);
5207
5208         case KEY_x:
5209             if (PL_expect == XOPERATOR)
5210                 Mop(OP_REPEAT);
5211             check_uni();
5212             goto just_a_word;
5213
5214         case KEY_xor:
5215             yylval.ival = OP_XOR;
5216             OPERATOR(OROP);
5217
5218         case KEY_y:
5219             s = scan_trans(s);
5220             TERM(sublex_start());
5221         }
5222     }}
5223 }
5224 #ifdef __SC__
5225 #pragma segment Main
5226 #endif
5227
5228 static int
5229 S_pending_ident(pTHX)
5230 {
5231     register char *d;
5232     register I32 tmp;
5233     /* pit holds the identifier we read and pending_ident is reset */
5234     char pit = PL_pending_ident;
5235     PL_pending_ident = 0;
5236
5237     DEBUG_T({ PerlIO_printf(Perl_debug_log,
5238           "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5239
5240     /* if we're in a my(), we can't allow dynamics here.
5241        $foo'bar has already been turned into $foo::bar, so
5242        just check for colons.
5243
5244        if it's a legal name, the OP is a PADANY.
5245     */
5246     if (PL_in_my) {
5247         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
5248             if (strchr(PL_tokenbuf,':'))
5249                 yyerror(Perl_form(aTHX_ "No package name allowed for "
5250                                   "variable %s in \"our\"",
5251                                   PL_tokenbuf));
5252             tmp = pad_allocmy(PL_tokenbuf);
5253         }
5254         else {
5255             if (strchr(PL_tokenbuf,':'))
5256                 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5257
5258             yylval.opval = newOP(OP_PADANY, 0);
5259             yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
5260             return PRIVATEREF;
5261         }
5262     }
5263
5264     /*
5265        build the ops for accesses to a my() variable.
5266
5267        Deny my($a) or my($b) in a sort block, *if* $a or $b is
5268        then used in a comparison.  This catches most, but not
5269        all cases.  For instance, it catches
5270            sort { my($a); $a <=> $b }
5271        but not
5272            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5273        (although why you'd do that is anyone's guess).
5274     */
5275
5276     if (!strchr(PL_tokenbuf,':')) {
5277 #ifdef USE_5005THREADS
5278         /* Check for single character per-thread SVs */
5279         if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
5280             && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
5281             && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
5282         {
5283             yylval.opval = newOP(OP_THREADSV, 0);
5284             yylval.opval->op_targ = tmp;
5285             return PRIVATEREF;
5286         }
5287 #endif /* USE_5005THREADS */
5288         if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
5289             SV *namesv = AvARRAY(PL_comppad_name)[tmp];
5290             /* might be an "our" variable" */
5291             if (SvFLAGS(namesv) & SVpad_OUR) {
5292                 /* build ops for a bareword */
5293                 SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0);
5294                 sv_catpvn(sym, "::", 2);
5295                 sv_catpv(sym, PL_tokenbuf+1);
5296                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5297                 yylval.opval->op_private = OPpCONST_ENTERED;
5298                 gv_fetchpv(SvPVX(sym),
5299                     (PL_in_eval
5300                         ? (GV_ADDMULTI | GV_ADDINEVAL)
5301                         : GV_ADDMULTI
5302                     ),
5303                     ((PL_tokenbuf[0] == '$') ? SVt_PV
5304                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5305                      : SVt_PVHV));
5306                 return WORD;
5307             }
5308
5309             /* if it's a sort block and they're naming $a or $b */
5310             if (PL_last_lop_op == OP_SORT &&
5311                 PL_tokenbuf[0] == '$' &&
5312                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5313                 && !PL_tokenbuf[2])
5314             {
5315                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5316                      d < PL_bufend && *d != '\n';
5317                      d++)
5318                 {
5319                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5320                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5321                               PL_tokenbuf);
5322                     }
5323                 }
5324             }
5325
5326             yylval.opval = newOP(OP_PADANY, 0);
5327             yylval.opval->op_targ = tmp;
5328             return PRIVATEREF;
5329         }
5330     }
5331
5332     /*
5333        Whine if they've said @foo in a doublequoted string,
5334        and @foo isn't a variable we can find in the symbol
5335        table.
5336     */
5337     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5338         GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5339         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5340              && ckWARN(WARN_AMBIGUOUS))
5341         {
5342             /* Downgraded from fatal to warning 20000522 mjd */
5343             Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5344                         "Possible unintended interpolation of %s in string",
5345                          PL_tokenbuf);
5346         }
5347     }
5348
5349     /* build ops for a bareword */
5350     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5351     yylval.opval->op_private = OPpCONST_ENTERED;
5352     gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5353                ((PL_tokenbuf[0] == '$') ? SVt_PV
5354                 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5355                 : SVt_PVHV));
5356     return WORD;
5357 }
5358
5359 I32
5360 Perl_keyword(pTHX_ register char *d, I32 len)
5361 {
5362     switch (*d) {
5363     case '_':
5364         if (d[1] == '_') {
5365             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
5366             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
5367             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
5368             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
5369             if (strEQ(d,"__END__"))             return KEY___END__;
5370         }
5371         break;
5372     case 'A':
5373         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
5374         break;
5375     case 'a':
5376         switch (len) {
5377         case 3:
5378             if (strEQ(d,"and"))                 return -KEY_and;
5379             if (strEQ(d,"abs"))                 return -KEY_abs;
5380             break;
5381         case 5:
5382             if (strEQ(d,"alarm"))               return -KEY_alarm;
5383             if (strEQ(d,"atan2"))               return -KEY_atan2;
5384             break;
5385         case 6:
5386             if (strEQ(d,"accept"))              return -KEY_accept;
5387             break;
5388         }
5389         break;
5390     case 'B':
5391         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
5392         break;
5393     case 'b':
5394         if (strEQ(d,"bless"))                   return -KEY_bless;
5395         if (strEQ(d,"bind"))                    return -KEY_bind;
5396         if (strEQ(d,"binmode"))                 return -KEY_binmode;
5397         break;
5398     case 'C':
5399         if (strEQ(d,"CORE"))                    return -KEY_CORE;
5400         if (strEQ(d,"CHECK"))                   return KEY_CHECK;
5401         break;
5402     case 'c':
5403         switch (len) {
5404         case 3:
5405             if (strEQ(d,"cmp"))                 return -KEY_cmp;
5406             if (strEQ(d,"chr"))                 return -KEY_chr;
5407             if (strEQ(d,"cos"))                 return -KEY_cos;
5408             break;
5409         case 4:
5410             if (strEQ(d,"chop"))                return -KEY_chop;
5411             break;
5412         case 5:
5413             if (strEQ(d,"close"))               return -KEY_close;
5414             if (strEQ(d,"chdir"))               return -KEY_chdir;
5415             if (strEQ(d,"chomp"))               return -KEY_chomp;
5416             if (strEQ(d,"chmod"))               return -KEY_chmod;
5417             if (strEQ(d,"chown"))               return -KEY_chown;
5418             if (strEQ(d,"crypt"))               return -KEY_crypt;
5419             break;
5420         case 6:
5421             if (strEQ(d,"chroot"))              return -KEY_chroot;
5422             if (strEQ(d,"caller"))              return -KEY_caller;
5423             break;
5424         case 7:
5425             if (strEQ(d,"connect"))             return -KEY_connect;
5426             break;
5427         case 8:
5428             if (strEQ(d,"closedir"))            return -KEY_closedir;
5429             if (strEQ(d,"continue"))            return -KEY_continue;
5430             break;
5431         }
5432         break;
5433     case 'D':
5434         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
5435         break;
5436     case 'd':
5437         switch (len) {
5438         case 2:
5439             if (strEQ(d,"do"))                  return KEY_do;
5440             break;
5441         case 3:
5442             if (strEQ(d,"die"))                 return -KEY_die;
5443             break;
5444         case 4:
5445             if (strEQ(d,"dump"))                return -KEY_dump;
5446             break;
5447         case 6:
5448             if (strEQ(d,"delete"))              return KEY_delete;
5449             break;
5450         case 7:
5451             if (strEQ(d,"defined"))             return KEY_defined;
5452             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
5453             break;
5454         case 8:
5455             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
5456             break;
5457         }
5458         break;
5459     case 'E':
5460         if (strEQ(d,"END"))                     return KEY_END;
5461         break;
5462     case 'e':
5463         switch (len) {
5464         case 2:
5465             if (strEQ(d,"eq"))                  return -KEY_eq;
5466             break;
5467         case 3:
5468             if (strEQ(d,"eof"))                 return -KEY_eof;
5469             if (strEQ(d,"err"))                 return -KEY_err;
5470             if (strEQ(d,"exp"))                 return -KEY_exp;
5471             break;
5472         case 4:
5473             if (strEQ(d,"else"))                return KEY_else;
5474             if (strEQ(d,"exit"))                return -KEY_exit;
5475             if (strEQ(d,"eval"))                return KEY_eval;
5476             if (strEQ(d,"exec"))                return -KEY_exec;
5477            if (strEQ(d,"each"))                return -KEY_each;
5478             break;
5479         case 5:
5480             if (strEQ(d,"elsif"))               return KEY_elsif;
5481             break;
5482         case 6:
5483             if (strEQ(d,"exists"))              return KEY_exists;
5484             if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
5485             break;
5486         case 8:
5487             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
5488             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
5489             break;
5490         case 9:
5491             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
5492             break;
5493         case 10:
5494             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
5495             if (strEQ(d,"endservent"))          return -KEY_endservent;
5496             break;
5497         case 11:
5498             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
5499             break;
5500         }
5501         break;
5502     case 'f':
5503         switch (len) {
5504         case 3:
5505             if (strEQ(d,"for"))                 return KEY_for;
5506             break;
5507         case 4:
5508             if (strEQ(d,"fork"))                return -KEY_fork;
5509             break;
5510         case 5:
5511             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
5512             if (strEQ(d,"flock"))               return -KEY_flock;
5513             break;
5514         case 6:
5515             if (strEQ(d,"format"))              return KEY_format;
5516             if (strEQ(d,"fileno"))              return -KEY_fileno;
5517             break;
5518         case 7:
5519             if (strEQ(d,"foreach"))             return KEY_foreach;
5520             break;
5521         case 8:
5522             if (strEQ(d,"formline"))            return -KEY_formline;
5523             break;
5524         }
5525         break;
5526     case 'g':
5527         if (strnEQ(d,"get",3)) {
5528             d += 3;
5529             if (*d == 'p') {
5530                 switch (len) {
5531                 case 7:
5532                     if (strEQ(d,"ppid"))        return -KEY_getppid;
5533                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
5534                     break;
5535                 case 8:
5536                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
5537                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
5538                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
5539                     break;
5540                 case 11:
5541                     if (strEQ(d,"peername"))    return -KEY_getpeername;
5542                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
5543                     if (strEQ(d,"priority"))    return -KEY_getpriority;
5544                     break;
5545                 case 14:
5546                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5547                     break;
5548                 case 16:
5549                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5550                     break;
5551                 }
5552             }
5553             else if (*d == 'h') {
5554                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
5555                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
5556                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
5557             }
5558             else if (*d == 'n') {
5559                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
5560                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
5561                 if (strEQ(d,"netent"))          return -KEY_getnetent;
5562             }
5563             else if (*d == 's') {
5564                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
5565                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
5566                 if (strEQ(d,"servent"))         return -KEY_getservent;
5567                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
5568                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
5569             }
5570             else if (*d == 'g') {
5571                 if (strEQ(d,"grent"))           return -KEY_getgrent;
5572                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
5573                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
5574             }
5575             else if (*d == 'l') {
5576                 if (strEQ(d,"login"))           return -KEY_getlogin;
5577             }
5578             else if (strEQ(d,"c"))              return -KEY_getc;
5579             break;
5580         }
5581         switch (len) {
5582         case 2:
5583             if (strEQ(d,"gt"))                  return -KEY_gt;
5584             if (strEQ(d,"ge"))                  return -KEY_ge;
5585             break;
5586         case 4:
5587             if (strEQ(d,"grep"))                return KEY_grep;
5588             if (strEQ(d,"goto"))                return KEY_goto;
5589             if (strEQ(d,"glob"))                return KEY_glob;
5590             break;
5591         case 6:
5592             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
5593             break;
5594         }
5595         break;
5596     case 'h':
5597         if (strEQ(d,"hex"))                     return -KEY_hex;
5598         break;
5599     case 'I':
5600         if (strEQ(d,"INIT"))                    return KEY_INIT;
5601         break;
5602     case 'i':
5603         switch (len) {
5604         case 2:
5605             if (strEQ(d,"if"))                  return KEY_if;
5606             break;
5607         case 3:
5608             if (strEQ(d,"int"))                 return -KEY_int;
5609             break;
5610         case 5:
5611             if (strEQ(d,"index"))               return -KEY_index;
5612             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
5613             break;
5614         }
5615         break;
5616     case 'j':
5617         if (strEQ(d,"join"))                    return -KEY_join;
5618         break;
5619     case 'k':
5620         if (len == 4) {
5621            if (strEQ(d,"keys"))                return -KEY_keys;
5622             if (strEQ(d,"kill"))                return -KEY_kill;
5623         }
5624         break;
5625     case 'l':
5626         switch (len) {
5627         case 2:
5628             if (strEQ(d,"lt"))                  return -KEY_lt;
5629             if (strEQ(d,"le"))                  return -KEY_le;
5630             if (strEQ(d,"lc"))                  return -KEY_lc;
5631             break;
5632         case 3:
5633             if (strEQ(d,"log"))                 return -KEY_log;
5634             break;
5635         case 4:
5636             if (strEQ(d,"last"))                return KEY_last;
5637             if (strEQ(d,"link"))                return -KEY_link;
5638             if (strEQ(d,"lock"))                return -KEY_lock;
5639             break;
5640         case 5:
5641             if (strEQ(d,"local"))               return KEY_local;
5642             if (strEQ(d,"lstat"))               return -KEY_lstat;
5643             break;
5644         case 6:
5645             if (strEQ(d,"length"))              return -KEY_length;
5646             if (strEQ(d,"listen"))              return -KEY_listen;
5647             break;
5648         case 7:
5649             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
5650             break;
5651         case 9:
5652             if (strEQ(d,"localtime"))           return -KEY_localtime;
5653             break;
5654         }
5655         break;
5656     case 'm':
5657         switch (len) {
5658         case 1:                                 return KEY_m;
5659         case 2:
5660             if (strEQ(d,"my"))                  return KEY_my;
5661             break;
5662         case 3:
5663             if (strEQ(d,"map"))                 return KEY_map;
5664             break;
5665         case 5:
5666             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
5667             break;
5668         case 6:
5669             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
5670             if (strEQ(d,"msgget"))              return -KEY_msgget;
5671             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
5672             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
5673             break;
5674         }
5675         break;
5676     case 'n':
5677         if (strEQ(d,"next"))                    return KEY_next;
5678         if (strEQ(d,"ne"))                      return -KEY_ne;
5679         if (strEQ(d,"not"))                     return -KEY_not;
5680         if (strEQ(d,"no"))                      return KEY_no;
5681         break;
5682     case 'o':
5683         switch (len) {
5684         case 2:
5685             if (strEQ(d,"or"))                  return -KEY_or;
5686             break;
5687         case 3:
5688             if (strEQ(d,"ord"))                 return -KEY_ord;
5689             if (strEQ(d,"oct"))                 return -KEY_oct;
5690             if (strEQ(d,"our"))                 return KEY_our;
5691             break;
5692         case 4:
5693             if (strEQ(d,"open"))                return -KEY_open;
5694             break;
5695         case 7:
5696             if (strEQ(d,"opendir"))             return -KEY_opendir;
5697             break;
5698         }
5699         break;
5700     case 'p':
5701         switch (len) {
5702         case 3:
5703            if (strEQ(d,"pop"))                 return -KEY_pop;
5704             if (strEQ(d,"pos"))                 return KEY_pos;
5705             break;
5706         case 4:
5707            if (strEQ(d,"push"))                return -KEY_push;
5708             if (strEQ(d,"pack"))                return -KEY_pack;
5709             if (strEQ(d,"pipe"))                return -KEY_pipe;
5710             break;
5711         case 5:
5712             if (strEQ(d,"print"))               return KEY_print;
5713             break;
5714         case 6:
5715             if (strEQ(d,"printf"))              return KEY_printf;
5716             break;
5717         case 7:
5718             if (strEQ(d,"package"))             return KEY_package;
5719             break;
5720         case 9:
5721             if (strEQ(d,"prototype"))           return KEY_prototype;
5722         }
5723         break;
5724     case 'q':
5725         if (len <= 2) {
5726             if (strEQ(d,"q"))                   return KEY_q;
5727             if (strEQ(d,"qr"))                  return KEY_qr;
5728             if (strEQ(d,"qq"))                  return KEY_qq;
5729             if (strEQ(d,"qw"))                  return KEY_qw;
5730             if (strEQ(d,"qx"))                  return KEY_qx;
5731         }
5732         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
5733         break;
5734     case 'r':
5735         switch (len) {
5736         case 3:
5737             if (strEQ(d,"ref"))                 return -KEY_ref;
5738             break;
5739         case 4:
5740             if (strEQ(d,"read"))                return -KEY_read;
5741             if (strEQ(d,"rand"))                return -KEY_rand;
5742             if (strEQ(d,"recv"))                return -KEY_recv;
5743             if (strEQ(d,"redo"))                return KEY_redo;
5744             break;
5745         case 5:
5746             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
5747             if (strEQ(d,"reset"))               return -KEY_reset;
5748             break;
5749         case 6:
5750             if (strEQ(d,"return"))              return KEY_return;
5751             if (strEQ(d,"rename"))              return -KEY_rename;
5752             if (strEQ(d,"rindex"))              return -KEY_rindex;
5753             break;
5754         case 7:
5755             if (strEQ(d,"require"))             return KEY_require;
5756             if (strEQ(d,"reverse"))             return -KEY_reverse;
5757             if (strEQ(d,"readdir"))             return -KEY_readdir;
5758             break;
5759         case 8:
5760             if (strEQ(d,"readlink"))            return -KEY_readlink;
5761             if (strEQ(d,"readline"))            return -KEY_readline;
5762             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
5763             break;
5764         case 9:
5765             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
5766             break;
5767         }
5768         break;
5769     case 's':
5770         switch (d[1]) {
5771         case 0:                                 return KEY_s;
5772         case 'c':
5773             if (strEQ(d,"scalar"))              return KEY_scalar;
5774             break;
5775         case 'e':
5776             switch (len) {
5777             case 4:
5778                 if (strEQ(d,"seek"))            return -KEY_seek;
5779                 if (strEQ(d,"send"))            return -KEY_send;
5780                 break;
5781             case 5:
5782                 if (strEQ(d,"semop"))           return -KEY_semop;
5783                 break;
5784             case 6:
5785                 if (strEQ(d,"select"))          return -KEY_select;
5786                 if (strEQ(d,"semctl"))          return -KEY_semctl;
5787                 if (strEQ(d,"semget"))          return -KEY_semget;
5788                 break;
5789             case 7:
5790                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
5791                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
5792                 break;
5793             case 8:
5794                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
5795                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
5796                 break;
5797             case 9:
5798                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
5799                 break;
5800             case 10:
5801                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
5802                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
5803                 if (strEQ(d,"setservent"))      return -KEY_setservent;
5804                 break;
5805             case 11:
5806                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
5807                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
5808                 break;
5809             }
5810             break;
5811         case 'h':
5812             switch (len) {
5813             case 5:
5814                if (strEQ(d,"shift"))           return -KEY_shift;
5815                 break;
5816             case 6:
5817                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
5818                 if (strEQ(d,"shmget"))          return -KEY_shmget;
5819                 break;
5820             case 7:
5821                 if (strEQ(d,"shmread"))         return -KEY_shmread;
5822                 break;
5823             case 8:
5824                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
5825                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
5826                 break;
5827             }
5828             break;
5829         case 'i':
5830             if (strEQ(d,"sin"))                 return -KEY_sin;
5831             break;
5832         case 'l':
5833             if (strEQ(d,"sleep"))               return -KEY_sleep;
5834             break;
5835         case 'o':
5836             if (strEQ(d,"sort"))                return KEY_sort;
5837             if (strEQ(d,"socket"))              return -KEY_socket;
5838             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
5839             break;
5840         case 'p':
5841             if (strEQ(d,"split"))               return KEY_split;
5842             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
5843            if (strEQ(d,"splice"))              return -KEY_splice;
5844             break;
5845         case 'q':
5846             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
5847             break;
5848         case 'r':
5849             if (strEQ(d,"srand"))               return -KEY_srand;
5850             break;
5851         case 't':
5852             if (strEQ(d,"stat"))                return -KEY_stat;
5853             if (strEQ(d,"study"))               return KEY_study;
5854             break;
5855         case 'u':
5856             if (strEQ(d,"substr"))              return -KEY_substr;
5857             if (strEQ(d,"sub"))                 return KEY_sub;
5858             break;
5859         case 'y':
5860             switch (len) {
5861             case 6:
5862                 if (strEQ(d,"system"))          return -KEY_system;
5863                 break;
5864             case 7:
5865                 if (strEQ(d,"symlink"))         return -KEY_symlink;
5866                 if (strEQ(d,"syscall"))         return -KEY_syscall;
5867                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
5868                 if (strEQ(d,"sysread"))         return -KEY_sysread;
5869                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
5870                 break;
5871             case 8:
5872                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
5873                 break;
5874             }
5875             break;
5876         }
5877         break;
5878     case 't':
5879         switch (len) {
5880         case 2:
5881             if (strEQ(d,"tr"))                  return KEY_tr;
5882             break;
5883         case 3:
5884             if (strEQ(d,"tie"))                 return KEY_tie;
5885             break;
5886         case 4:
5887             if (strEQ(d,"tell"))                return -KEY_tell;
5888             if (strEQ(d,"tied"))                return KEY_tied;
5889             if (strEQ(d,"time"))                return -KEY_time;
5890             break;
5891         case 5:
5892             if (strEQ(d,"times"))               return -KEY_times;
5893             break;
5894         case 7:
5895             if (strEQ(d,"telldir"))             return -KEY_telldir;
5896             break;
5897         case 8:
5898             if (strEQ(d,"truncate"))            return -KEY_truncate;
5899             break;
5900         }
5901         break;
5902     case 'u':
5903         switch (len) {
5904         case 2:
5905             if (strEQ(d,"uc"))                  return -KEY_uc;
5906             break;
5907         case 3:
5908             if (strEQ(d,"use"))                 return KEY_use;
5909             break;
5910         case 5:
5911             if (strEQ(d,"undef"))               return KEY_undef;
5912             if (strEQ(d,"until"))               return KEY_until;
5913             if (strEQ(d,"untie"))               return KEY_untie;
5914             if (strEQ(d,"utime"))               return -KEY_utime;
5915             if (strEQ(d,"umask"))               return -KEY_umask;
5916             break;
5917         case 6:
5918             if (strEQ(d,"unless"))              return KEY_unless;
5919             if (strEQ(d,"unpack"))              return -KEY_unpack;
5920             if (strEQ(d,"unlink"))              return -KEY_unlink;
5921             break;
5922         case 7:
5923            if (strEQ(d,"unshift"))             return -KEY_unshift;
5924             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
5925             break;
5926         }
5927         break;
5928     case 'v':
5929         if (strEQ(d,"values"))                  return -KEY_values;
5930         if (strEQ(d,"vec"))                     return -KEY_vec;
5931         break;
5932     case 'w':
5933         switch (len) {
5934         case 4:
5935             if (strEQ(d,"warn"))                return -KEY_warn;
5936             if (strEQ(d,"wait"))                return -KEY_wait;
5937             break;
5938         case 5:
5939             if (strEQ(d,"while"))               return KEY_while;
5940             if (strEQ(d,"write"))               return -KEY_write;
5941             break;
5942         case 7:
5943             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
5944             break;
5945         case 9:
5946             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
5947             break;
5948         }
5949         break;
5950     case 'x':
5951         if (len == 1)                           return -KEY_x;
5952         if (strEQ(d,"xor"))                     return -KEY_xor;
5953         break;
5954     case 'y':
5955         if (len == 1)                           return KEY_y;
5956         break;
5957     case 'z':
5958         break;
5959     }
5960     return 0;
5961 }
5962
5963 STATIC void
5964 S_checkcomma(pTHX_ register char *s, char *name, char *what)
5965 {
5966     char *w;
5967
5968     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
5969         if (ckWARN(WARN_SYNTAX)) {
5970             int level = 1;
5971             for (w = s+2; *w && level; w++) {
5972                 if (*w == '(')
5973                     ++level;
5974                 else if (*w == ')')
5975                     --level;
5976             }
5977             if (*w)
5978                 for (; *w && isSPACE(*w); w++) ;
5979             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
5980                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5981                             "%s (...) interpreted as function",name);
5982         }
5983     }
5984     while (s < PL_bufend && isSPACE(*s))
5985         s++;
5986     if (*s == '(')
5987         s++;
5988     while (s < PL_bufend && isSPACE(*s))
5989         s++;
5990     if (isIDFIRST_lazy_if(s,UTF)) {
5991         w = s++;
5992         while (isALNUM_lazy_if(s,UTF))
5993             s++;
5994         while (s < PL_bufend && isSPACE(*s))
5995             s++;
5996         if (*s == ',') {
5997             int kw;
5998             *s = '\0';
5999             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
6000             *s = ',';
6001             if (kw)
6002                 return;
6003             Perl_croak(aTHX_ "No comma allowed after %s", what);
6004         }
6005     }
6006 }
6007
6008 /* Either returns sv, or mortalizes sv and returns a new SV*.
6009    Best used as sv=new_constant(..., sv, ...).
6010    If s, pv are NULL, calls subroutine with one argument,
6011    and type is used with error messages only. */
6012
6013 STATIC SV *
6014 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
6015                const char *type)
6016 {
6017     dSP;
6018     HV *table = GvHV(PL_hintgv);                 /* ^H */
6019     SV *res;
6020     SV **cvp;
6021     SV *cv, *typesv;
6022     const char *why1, *why2, *why3;
6023
6024     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
6025         SV *msg;
6026         
6027         why2 = strEQ(key,"charnames")
6028                ? "(possibly a missing \"use charnames ...\")"
6029                : "";
6030         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
6031                             (type ? type: "undef"), why2);
6032
6033         /* This is convoluted and evil ("goto considered harmful")
6034          * but I do not understand the intricacies of all the different
6035          * failure modes of %^H in here.  The goal here is to make
6036          * the most probable error message user-friendly. --jhi */
6037
6038         goto msgdone;
6039
6040     report:
6041         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
6042                             (type ? type: "undef"), why1, why2, why3);
6043     msgdone:
6044         yyerror(SvPVX(msg));
6045         SvREFCNT_dec(msg);
6046         return sv;
6047     }
6048     cvp = hv_fetch(table, key, strlen(key), FALSE);
6049     if (!cvp || !SvOK(*cvp)) {
6050         why1 = "$^H{";
6051         why2 = key;
6052         why3 = "} is not defined";
6053         goto report;
6054     }
6055     sv_2mortal(sv);                     /* Parent created it permanently */
6056     cv = *cvp;
6057     if (!pv && s)
6058         pv = sv_2mortal(newSVpvn(s, len));
6059     if (type && pv)
6060         typesv = sv_2mortal(newSVpv(type, 0));
6061     else
6062         typesv = &PL_sv_undef;
6063
6064     PUSHSTACKi(PERLSI_OVERLOAD);
6065     ENTER ;
6066     SAVETMPS;
6067
6068     PUSHMARK(SP) ;
6069     EXTEND(sp, 3);
6070     if (pv)
6071         PUSHs(pv);
6072     PUSHs(sv);
6073     if (pv)
6074         PUSHs(typesv);
6075     PUTBACK;
6076     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
6077
6078     SPAGAIN ;
6079
6080     /* Check the eval first */
6081     if (!PL_in_eval && SvTRUE(ERRSV)) {
6082         STRLEN n_a;
6083         sv_catpv(ERRSV, "Propagated");
6084         yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
6085         (void)POPs;
6086         res = SvREFCNT_inc(sv);
6087     }
6088     else {
6089         res = POPs;
6090         (void)SvREFCNT_inc(res);
6091     }
6092
6093     PUTBACK ;
6094     FREETMPS ;
6095     LEAVE ;
6096     POPSTACK;
6097
6098     if (!SvOK(res)) {
6099         why1 = "Call to &{$^H{";
6100         why2 = key;
6101         why3 = "}} did not return a defined value";
6102         sv = res;
6103         goto report;
6104     }
6105
6106     return res;
6107 }
6108
6109 STATIC char *
6110 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6111 {
6112     register char *d = dest;
6113     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
6114     for (;;) {
6115         if (d >= e)
6116             Perl_croak(aTHX_ ident_too_long);
6117         if (isALNUM(*s))        /* UTF handled below */
6118             *d++ = *s++;
6119         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6120             *d++ = ':';
6121             *d++ = ':';
6122             s++;
6123         }
6124         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6125             *d++ = *s++;
6126             *d++ = *s++;
6127         }
6128         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6129             char *t = s + UTF8SKIP(s);
6130             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6131                 t += UTF8SKIP(t);
6132             if (d + (t - s) > e)
6133                 Perl_croak(aTHX_ ident_too_long);
6134             Copy(s, d, t - s, char);
6135             d += t - s;
6136             s = t;
6137         }
6138         else {
6139             *d = '\0';
6140             *slp = d - dest;
6141             return s;
6142         }
6143     }
6144 }
6145
6146 STATIC char *
6147 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6148 {
6149     register char *d;
6150     register char *e;
6151     char *bracket = 0;
6152     char funny = *s++;
6153
6154     if (isSPACE(*s))
6155         s = skipspace(s);
6156     d = dest;
6157     e = d + destlen - 3;        /* two-character token, ending NUL */
6158     if (isDIGIT(*s)) {
6159         while (isDIGIT(*s)) {
6160             if (d >= e)
6161                 Perl_croak(aTHX_ ident_too_long);
6162             *d++ = *s++;
6163         }
6164     }
6165     else {
6166         for (;;) {
6167             if (d >= e)
6168                 Perl_croak(aTHX_ ident_too_long);
6169             if (isALNUM(*s))    /* UTF handled below */
6170                 *d++ = *s++;
6171             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6172                 *d++ = ':';
6173                 *d++ = ':';
6174                 s++;
6175             }
6176             else if (*s == ':' && s[1] == ':') {
6177                 *d++ = *s++;
6178                 *d++ = *s++;
6179             }
6180             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6181                 char *t = s + UTF8SKIP(s);
6182                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6183                     t += UTF8SKIP(t);
6184                 if (d + (t - s) > e)
6185                     Perl_croak(aTHX_ ident_too_long);
6186                 Copy(s, d, t - s, char);
6187                 d += t - s;
6188                 s = t;
6189             }
6190             else
6191                 break;
6192         }
6193     }
6194     *d = '\0';
6195     d = dest;
6196     if (*d) {
6197         if (PL_lex_state != LEX_NORMAL)
6198             PL_lex_state = LEX_INTERPENDMAYBE;
6199         return s;
6200     }
6201     if (*s == '$' && s[1] &&
6202         (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6203     {
6204         return s;
6205     }
6206     if (*s == '{') {
6207         bracket = s;
6208         s++;
6209     }
6210     else if (ck_uni)
6211         check_uni();
6212     if (s < send)
6213         *d = *s++;
6214     d[1] = '\0';
6215     if (*d == '^' && *s && isCONTROLVAR(*s)) {
6216         *d = toCTRL(*s);
6217         s++;
6218     }
6219     if (bracket) {
6220         if (isSPACE(s[-1])) {
6221             while (s < send) {
6222                 char ch = *s++;
6223                 if (!SPACE_OR_TAB(ch)) {
6224                     *d = ch;
6225                     break;
6226                 }
6227             }
6228         }
6229         if (isIDFIRST_lazy_if(d,UTF)) {
6230             d++;
6231             if (UTF) {
6232                 e = s;
6233                 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6234                     e += UTF8SKIP(e);
6235                     while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6236                         e += UTF8SKIP(e);
6237                 }
6238                 Copy(s, d, e - s, char);
6239                 d += e - s;
6240                 s = e;
6241             }
6242             else {
6243                 while ((isALNUM(*s) || *s == ':') && d < e)
6244                     *d++ = *s++;
6245                 if (d >= e)
6246                     Perl_croak(aTHX_ ident_too_long);
6247             }
6248             *d = '\0';
6249             while (s < send && SPACE_OR_TAB(*s)) s++;
6250             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6251                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6252                     const char *brack = *s == '[' ? "[...]" : "{...}";
6253                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6254                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6255                         funny, dest, brack, funny, dest, brack);
6256                 }
6257                 bracket++;
6258                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6259                 return s;
6260             }
6261         }
6262         /* Handle extended ${^Foo} variables
6263          * 1999-02-27 mjd-perl-patch@plover.com */
6264         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6265                  && isALNUM(*s))
6266         {
6267             d++;
6268             while (isALNUM(*s) && d < e) {
6269                 *d++ = *s++;
6270             }
6271             if (d >= e)
6272                 Perl_croak(aTHX_ ident_too_long);
6273             *d = '\0';
6274         }
6275         if (*s == '}') {
6276             s++;
6277             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
6278                 PL_lex_state = LEX_INTERPEND;
6279             if (funny == '#')
6280                 funny = '@';
6281             if (PL_lex_state == LEX_NORMAL) {
6282                 if (ckWARN(WARN_AMBIGUOUS) &&
6283                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6284                 {
6285                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6286                         "Ambiguous use of %c{%s} resolved to %c%s",
6287                         funny, dest, funny, dest);
6288                 }
6289             }
6290         }
6291         else {
6292             s = bracket;                /* let the parser handle it */
6293             *dest = '\0';
6294         }
6295     }
6296     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6297         PL_lex_state = LEX_INTERPEND;
6298     return s;
6299 }
6300
6301 void
6302 Perl_pmflag(pTHX_ U32* pmfl, int ch)
6303 {
6304     if (ch == 'i')
6305         *pmfl |= PMf_FOLD;
6306     else if (ch == 'g')
6307         *pmfl |= PMf_GLOBAL;
6308     else if (ch == 'c')
6309         *pmfl |= PMf_CONTINUE;
6310     else if (ch == 'o')
6311         *pmfl |= PMf_KEEP;
6312     else if (ch == 'm')
6313         *pmfl |= PMf_MULTILINE;
6314     else if (ch == 's')
6315         *pmfl |= PMf_SINGLELINE;
6316     else if (ch == 'x')
6317         *pmfl |= PMf_EXTENDED;
6318 }
6319
6320 STATIC char *
6321 S_scan_pat(pTHX_ char *start, I32 type)
6322 {
6323     PMOP *pm;
6324     char *s;
6325
6326     s = scan_str(start,FALSE,FALSE);
6327     if (!s)
6328         Perl_croak(aTHX_ "Search pattern not terminated");
6329
6330     pm = (PMOP*)newPMOP(type, 0);
6331     if (PL_multi_open == '?')
6332         pm->op_pmflags |= PMf_ONCE;
6333     if(type == OP_QR) {
6334         while (*s && strchr("iomsx", *s))
6335             pmflag(&pm->op_pmflags,*s++);
6336     }
6337     else {
6338         while (*s && strchr("iogcmsx", *s))
6339             pmflag(&pm->op_pmflags,*s++);
6340     }
6341     /* issue a warning if /c is specified,but /g is not */
6342     if (ckWARN(WARN_REGEXP) && 
6343         (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
6344     {
6345         Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
6346     }
6347
6348     pm->op_pmpermflags = pm->op_pmflags;
6349
6350     PL_lex_op = (OP*)pm;
6351     yylval.ival = OP_MATCH;
6352     return s;
6353 }
6354
6355 STATIC char *
6356 S_scan_subst(pTHX_ char *start)
6357 {
6358     register char *s;
6359     register PMOP *pm;
6360     I32 first_start;
6361     I32 es = 0;
6362
6363     yylval.ival = OP_NULL;
6364
6365     s = scan_str(start,FALSE,FALSE);
6366
6367     if (!s)
6368         Perl_croak(aTHX_ "Substitution pattern not terminated");
6369
6370     if (s[-1] == PL_multi_open)
6371         s--;
6372
6373     first_start = PL_multi_start;
6374     s = scan_str(s,FALSE,FALSE);
6375     if (!s) {
6376         if (PL_lex_stuff) {
6377             SvREFCNT_dec(PL_lex_stuff);
6378             PL_lex_stuff = Nullsv;
6379         }
6380         Perl_croak(aTHX_ "Substitution replacement not terminated");
6381     }
6382     PL_multi_start = first_start;       /* so whole substitution is taken together */
6383
6384     pm = (PMOP*)newPMOP(OP_SUBST, 0);
6385     while (*s) {
6386         if (*s == 'e') {
6387             s++;
6388             es++;
6389         }
6390         else if (strchr("iogcmsx", *s))
6391             pmflag(&pm->op_pmflags,*s++);
6392         else
6393             break;
6394     }
6395
6396     /* /c is not meaningful with s/// */
6397     if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
6398     {
6399         Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
6400     }
6401
6402     if (es) {
6403         SV *repl;
6404         PL_sublex_info.super_bufptr = s;
6405         PL_sublex_info.super_bufend = PL_bufend;
6406         PL_multi_end = 0;
6407         pm->op_pmflags |= PMf_EVAL;
6408         repl = newSVpvn("",0);
6409         while (es-- > 0)
6410             sv_catpv(repl, es ? "eval " : "do ");
6411         sv_catpvn(repl, "{ ", 2);
6412         sv_catsv(repl, PL_lex_repl);
6413         sv_catpvn(repl, " };", 2);
6414         SvEVALED_on(repl);
6415         SvREFCNT_dec(PL_lex_repl);
6416         PL_lex_repl = repl;
6417     }
6418
6419     pm->op_pmpermflags = pm->op_pmflags;
6420     PL_lex_op = (OP*)pm;
6421     yylval.ival = OP_SUBST;
6422     return s;
6423 }
6424
6425 STATIC char *
6426 S_scan_trans(pTHX_ char *start)
6427 {
6428     register char* s;
6429     OP *o;
6430     short *tbl;
6431     I32 squash;
6432     I32 del;
6433     I32 complement;
6434
6435     yylval.ival = OP_NULL;
6436
6437     s = scan_str(start,FALSE,FALSE);
6438     if (!s)
6439         Perl_croak(aTHX_ "Transliteration pattern not terminated");
6440     if (s[-1] == PL_multi_open)
6441         s--;
6442
6443     s = scan_str(s,FALSE,FALSE);
6444     if (!s) {
6445         if (PL_lex_stuff) {
6446             SvREFCNT_dec(PL_lex_stuff);
6447             PL_lex_stuff = Nullsv;
6448         }
6449         Perl_croak(aTHX_ "Transliteration replacement not terminated");
6450     }
6451
6452     complement = del = squash = 0;
6453     while (strchr("cds", *s)) {
6454         if (*s == 'c')
6455             complement = OPpTRANS_COMPLEMENT;
6456         else if (*s == 'd')
6457             del = OPpTRANS_DELETE;
6458         else if (*s == 's')
6459             squash = OPpTRANS_SQUASH;
6460         s++;
6461     }
6462
6463     New(803, tbl, complement&&!del?258:256, short);
6464     o = newPVOP(OP_TRANS, 0, (char*)tbl);
6465     o->op_private = del|squash|complement|
6466       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6467       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
6468
6469     PL_lex_op = o;
6470     yylval.ival = OP_TRANS;
6471     return s;
6472 }
6473
6474 STATIC char *
6475 S_scan_heredoc(pTHX_ register char *s)
6476 {
6477     SV *herewas;
6478     I32 op_type = OP_SCALAR;
6479     I32 len;
6480     SV *tmpstr;
6481     char term;
6482     register char *d;
6483     register char *e;
6484     char *peek;
6485     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6486
6487     s += 2;
6488     d = PL_tokenbuf;
6489     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6490     if (!outer)
6491         *d++ = '\n';
6492     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6493     if (*peek && strchr("`'\"",*peek)) {
6494         s = peek;
6495         term = *s++;
6496         s = delimcpy(d, e, s, PL_bufend, term, &len);
6497         d += len;
6498         if (s < PL_bufend)
6499             s++;
6500     }
6501     else {
6502         if (*s == '\\')
6503             s++, term = '\'';
6504         else
6505             term = '"';
6506         if (!isALNUM_lazy_if(s,UTF))
6507             deprecate_old("bare << to mean <<\"\"");
6508         for (; isALNUM_lazy_if(s,UTF); s++) {
6509             if (d < e)
6510                 *d++ = *s;
6511         }
6512     }
6513     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6514         Perl_croak(aTHX_ "Delimiter for here document is too long");
6515     *d++ = '\n';
6516     *d = '\0';
6517     len = d - PL_tokenbuf;
6518 #ifndef PERL_STRICT_CR
6519     d = strchr(s, '\r');
6520     if (d) {
6521         char *olds = s;
6522         s = d;
6523         while (s < PL_bufend) {
6524             if (*s == '\r') {
6525                 *d++ = '\n';
6526                 if (*++s == '\n')
6527                     s++;
6528             }
6529             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
6530                 *d++ = *s++;
6531                 s++;
6532             }
6533             else
6534                 *d++ = *s++;
6535         }
6536         *d = '\0';
6537         PL_bufend = d;
6538         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6539         s = olds;
6540     }
6541 #endif
6542     d = "\n";
6543     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6544         herewas = newSVpvn(s,PL_bufend-s);
6545     else
6546         s--, herewas = newSVpvn(s,d-s);
6547     s += SvCUR(herewas);
6548
6549     tmpstr = NEWSV(87,79);
6550     sv_upgrade(tmpstr, SVt_PVIV);
6551     if (term == '\'') {
6552         op_type = OP_CONST;
6553         SvIVX(tmpstr) = -1;
6554     }
6555     else if (term == '`') {
6556         op_type = OP_BACKTICK;
6557         SvIVX(tmpstr) = '\\';
6558     }
6559
6560     CLINE;
6561     PL_multi_start = CopLINE(PL_curcop);
6562     PL_multi_open = PL_multi_close = '<';
6563     term = *PL_tokenbuf;
6564     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6565         char *bufptr = PL_sublex_info.super_bufptr;
6566         char *bufend = PL_sublex_info.super_bufend;
6567         char *olds = s - SvCUR(herewas);
6568         s = strchr(bufptr, '\n');
6569         if (!s)
6570             s = bufend;
6571         d = s;
6572         while (s < bufend &&
6573           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6574             if (*s++ == '\n')
6575                 CopLINE_inc(PL_curcop);
6576         }
6577         if (s >= bufend) {
6578             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6579             missingterm(PL_tokenbuf);
6580         }
6581         sv_setpvn(herewas,bufptr,d-bufptr+1);
6582         sv_setpvn(tmpstr,d+1,s-d);
6583         s += len - 1;
6584         sv_catpvn(herewas,s,bufend-s);
6585         (void)strcpy(bufptr,SvPVX(herewas));
6586
6587         s = olds;
6588         goto retval;
6589     }
6590     else if (!outer) {
6591         d = s;
6592         while (s < PL_bufend &&
6593           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6594             if (*s++ == '\n')
6595                 CopLINE_inc(PL_curcop);
6596         }
6597         if (s >= PL_bufend) {
6598             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6599             missingterm(PL_tokenbuf);
6600         }
6601         sv_setpvn(tmpstr,d+1,s-d);
6602         s += len - 1;
6603         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6604
6605         sv_catpvn(herewas,s,PL_bufend-s);
6606         sv_setsv(PL_linestr,herewas);
6607         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6608         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6609         PL_last_lop = PL_last_uni = Nullch;
6610     }
6611     else
6612         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
6613     while (s >= PL_bufend) {    /* multiple line string? */
6614         if (!outer ||
6615          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6616             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6617             missingterm(PL_tokenbuf);
6618         }
6619         CopLINE_inc(PL_curcop);
6620         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6621         PL_last_lop = PL_last_uni = Nullch;
6622 #ifndef PERL_STRICT_CR
6623         if (PL_bufend - PL_linestart >= 2) {
6624             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6625                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6626             {
6627                 PL_bufend[-2] = '\n';
6628                 PL_bufend--;
6629                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6630             }
6631             else if (PL_bufend[-1] == '\r')
6632                 PL_bufend[-1] = '\n';
6633         }
6634         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6635             PL_bufend[-1] = '\n';
6636 #endif
6637         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6638             SV *sv = NEWSV(88,0);
6639
6640             sv_upgrade(sv, SVt_PVMG);
6641             sv_setsv(sv,PL_linestr);
6642             (void)SvIOK_on(sv);
6643             SvIVX(sv) = 0;
6644             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6645         }
6646         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6647             s = PL_bufend - 1;
6648             *s = ' ';
6649             sv_catsv(PL_linestr,herewas);
6650             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6651         }
6652         else {
6653             s = PL_bufend;
6654             sv_catsv(tmpstr,PL_linestr);
6655         }
6656     }
6657     s++;
6658 retval:
6659     PL_multi_end = CopLINE(PL_curcop);
6660     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6661         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6662         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6663     }
6664     SvREFCNT_dec(herewas);
6665     if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6666         SvUTF8_on(tmpstr);
6667     PL_lex_stuff = tmpstr;
6668     yylval.ival = op_type;
6669     return s;
6670 }
6671
6672 /* scan_inputsymbol
6673    takes: current position in input buffer
6674    returns: new position in input buffer
6675    side-effects: yylval and lex_op are set.
6676
6677    This code handles:
6678
6679    <>           read from ARGV
6680    <FH>         read from filehandle
6681    <pkg::FH>    read from package qualified filehandle
6682    <pkg'FH>     read from package qualified filehandle
6683    <$fh>        read from filehandle in $fh
6684    <*.h>        filename glob
6685
6686 */
6687
6688 STATIC char *
6689 S_scan_inputsymbol(pTHX_ char *start)
6690 {
6691     register char *s = start;           /* current position in buffer */
6692     register char *d;
6693     register char *e;
6694     char *end;
6695     I32 len;
6696
6697     d = PL_tokenbuf;                    /* start of temp holding space */
6698     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
6699     end = strchr(s, '\n');
6700     if (!end)
6701         end = PL_bufend;
6702     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
6703
6704     /* die if we didn't have space for the contents of the <>,
6705        or if it didn't end, or if we see a newline
6706     */
6707
6708     if (len >= sizeof PL_tokenbuf)
6709         Perl_croak(aTHX_ "Excessively long <> operator");
6710     if (s >= end)
6711         Perl_croak(aTHX_ "Unterminated <> operator");
6712
6713     s++;
6714
6715     /* check for <$fh>
6716        Remember, only scalar variables are interpreted as filehandles by
6717        this code.  Anything more complex (e.g., <$fh{$num}>) will be
6718        treated as a glob() call.
6719        This code makes use of the fact that except for the $ at the front,
6720        a scalar variable and a filehandle look the same.
6721     */
6722     if (*d == '$' && d[1]) d++;
6723
6724     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6725     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6726         d++;
6727
6728     /* If we've tried to read what we allow filehandles to look like, and
6729        there's still text left, then it must be a glob() and not a getline.
6730        Use scan_str to pull out the stuff between the <> and treat it
6731        as nothing more than a string.
6732     */
6733
6734     if (d - PL_tokenbuf != len) {
6735         yylval.ival = OP_GLOB;
6736         set_csh();
6737         s = scan_str(start,FALSE,FALSE);
6738         if (!s)
6739            Perl_croak(aTHX_ "Glob not terminated");
6740         return s;
6741     }
6742     else {
6743         bool readline_overriden = FALSE;
6744         GV *gv_readline = Nullgv;
6745         GV **gvp;
6746         /* we're in a filehandle read situation */
6747         d = PL_tokenbuf;
6748
6749         /* turn <> into <ARGV> */
6750         if (!len)
6751             (void)strcpy(d,"ARGV");
6752
6753         /* Check whether readline() is overriden */
6754         if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
6755                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
6756                 ||
6757                 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
6758                 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
6759                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
6760             readline_overriden = TRUE;
6761
6762         /* if <$fh>, create the ops to turn the variable into a
6763            filehandle
6764         */
6765         if (*d == '$') {
6766             I32 tmp;
6767
6768             /* try to find it in the pad for this block, otherwise find
6769                add symbol table ops
6770             */
6771             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6772                 SV *namesv = AvARRAY(PL_comppad_name)[tmp];
6773                 if (SvFLAGS(namesv) & SVpad_OUR) {
6774                     SV *sym = sv_2mortal(newSVpv(HvNAME(GvSTASH(namesv)),0));
6775                     sv_catpvn(sym, "::", 2);
6776                     sv_catpv(sym, d+1);
6777                     d = SvPVX(sym);
6778                     goto intro_sym;
6779                 }
6780                 else {
6781                     OP *o = newOP(OP_PADSV, 0);
6782                     o->op_targ = tmp;
6783                     PL_lex_op = readline_overriden
6784                         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6785                                 append_elem(OP_LIST, o,
6786                                     newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
6787                         : (OP*)newUNOP(OP_READLINE, 0, o);
6788                 }
6789             }
6790             else {
6791                 GV *gv;
6792                 ++d;
6793 intro_sym:
6794                 gv = gv_fetchpv(d,
6795                                 (PL_in_eval
6796                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
6797                                  : GV_ADDMULTI),
6798                                 SVt_PV);
6799                 PL_lex_op = readline_overriden
6800                     ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6801                             append_elem(OP_LIST,
6802                                 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
6803                                 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6804                     : (OP*)newUNOP(OP_READLINE, 0,
6805                             newUNOP(OP_RV2SV, 0,
6806                                 newGVOP(OP_GV, 0, gv)));
6807             }
6808             if (!readline_overriden)
6809                 PL_lex_op->op_flags |= OPf_SPECIAL;
6810             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6811             yylval.ival = OP_NULL;
6812         }
6813
6814         /* If it's none of the above, it must be a literal filehandle
6815            (<Foo::BAR> or <FOO>) so build a simple readline OP */
6816         else {
6817             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6818             PL_lex_op = readline_overriden
6819                 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6820                         append_elem(OP_LIST,
6821                             newGVOP(OP_GV, 0, gv),
6822                             newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6823                 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6824             yylval.ival = OP_NULL;
6825         }
6826     }
6827
6828     return s;
6829 }
6830
6831
6832 /* scan_str
6833    takes: start position in buffer
6834           keep_quoted preserve \ on the embedded delimiter(s)
6835           keep_delims preserve the delimiters around the string
6836    returns: position to continue reading from buffer
6837    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6838         updates the read buffer.
6839
6840    This subroutine pulls a string out of the input.  It is called for:
6841         q               single quotes           q(literal text)
6842         '               single quotes           'literal text'
6843         qq              double quotes           qq(interpolate $here please)
6844         "               double quotes           "interpolate $here please"
6845         qx              backticks               qx(/bin/ls -l)
6846         `               backticks               `/bin/ls -l`
6847         qw              quote words             @EXPORT_OK = qw( func() $spam )
6848         m//             regexp match            m/this/
6849         s///            regexp substitute       s/this/that/
6850         tr///           string transliterate    tr/this/that/
6851         y///            string transliterate    y/this/that/
6852         ($*@)           sub prototypes          sub foo ($)
6853         (stuff)         sub attr parameters     sub foo : attr(stuff)
6854         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
6855         
6856    In most of these cases (all but <>, patterns and transliterate)
6857    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
6858    calls scan_str().  s/// makes yylex() call scan_subst() which calls
6859    scan_str().  tr/// and y/// make yylex() call scan_trans() which
6860    calls scan_str().
6861
6862    It skips whitespace before the string starts, and treats the first
6863    character as the delimiter.  If the delimiter is one of ([{< then
6864    the corresponding "close" character )]}> is used as the closing
6865    delimiter.  It allows quoting of delimiters, and if the string has
6866    balanced delimiters ([{<>}]) it allows nesting.
6867
6868    On success, the SV with the resulting string is put into lex_stuff or,
6869    if that is already non-NULL, into lex_repl. The second case occurs only
6870    when parsing the RHS of the special constructs s/// and tr/// (y///).
6871    For convenience, the terminating delimiter character is stuffed into
6872    SvIVX of the SV.
6873 */
6874
6875 STATIC char *
6876 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6877 {
6878     SV *sv;                             /* scalar value: string */
6879     char *tmps;                         /* temp string, used for delimiter matching */
6880     register char *s = start;           /* current position in the buffer */
6881     register char term;                 /* terminating character */
6882     register char *to;                  /* current position in the sv's data */
6883     I32 brackets = 1;                   /* bracket nesting level */
6884     bool has_utf8 = FALSE;              /* is there any utf8 content? */
6885
6886     /* skip space before the delimiter */
6887     if (isSPACE(*s))
6888         s = skipspace(s);
6889
6890     /* mark where we are, in case we need to report errors */
6891     CLINE;
6892
6893     /* after skipping whitespace, the next character is the terminator */
6894     term = *s;
6895     if (!UTF8_IS_INVARIANT((U8)term) && UTF)
6896         has_utf8 = TRUE;
6897
6898     /* mark where we are */
6899     PL_multi_start = CopLINE(PL_curcop);
6900     PL_multi_open = term;
6901
6902     /* find corresponding closing delimiter */
6903     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6904         term = tmps[5];
6905     PL_multi_close = term;
6906
6907     /* create a new SV to hold the contents.  87 is leak category, I'm
6908        assuming.  79 is the SV's initial length.  What a random number. */
6909     sv = NEWSV(87,79);
6910     sv_upgrade(sv, SVt_PVIV);
6911     SvIVX(sv) = term;
6912     (void)SvPOK_only(sv);               /* validate pointer */
6913
6914     /* move past delimiter and try to read a complete string */
6915     if (keep_delims)
6916         sv_catpvn(sv, s, 1);
6917     s++;
6918     for (;;) {
6919         /* extend sv if need be */
6920         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
6921         /* set 'to' to the next character in the sv's string */
6922         to = SvPVX(sv)+SvCUR(sv);
6923
6924         /* if open delimiter is the close delimiter read unbridle */
6925         if (PL_multi_open == PL_multi_close) {
6926             for (; s < PL_bufend; s++,to++) {
6927                 /* embedded newlines increment the current line number */
6928                 if (*s == '\n' && !PL_rsfp)
6929                     CopLINE_inc(PL_curcop);
6930                 /* handle quoted delimiters */
6931                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
6932                     if (!keep_quoted && s[1] == term)
6933                         s++;
6934                 /* any other quotes are simply copied straight through */
6935                     else
6936                         *to++ = *s++;
6937                 }
6938                 /* terminate when run out of buffer (the for() condition), or
6939                    have found the terminator */
6940                 else if (*s == term)
6941                     break;
6942                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6943                     has_utf8 = TRUE;
6944                 *to = *s;
6945             }
6946         }
6947         
6948         /* if the terminator isn't the same as the start character (e.g.,
6949            matched brackets), we have to allow more in the quoting, and
6950            be prepared for nested brackets.
6951         */
6952         else {
6953             /* read until we run out of string, or we find the terminator */
6954             for (; s < PL_bufend; s++,to++) {
6955                 /* embedded newlines increment the line count */
6956                 if (*s == '\n' && !PL_rsfp)
6957                     CopLINE_inc(PL_curcop);
6958                 /* backslashes can escape the open or closing characters */
6959                 if (*s == '\\' && s+1 < PL_bufend) {
6960                     if (!keep_quoted &&
6961                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
6962                         s++;
6963                     else
6964                         *to++ = *s++;
6965                 }
6966                 /* allow nested opens and closes */
6967                 else if (*s == PL_multi_close && --brackets <= 0)
6968                     break;
6969                 else if (*s == PL_multi_open)
6970                     brackets++;
6971                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
6972                     has_utf8 = TRUE;
6973                 *to = *s;
6974             }
6975         }
6976         /* terminate the copied string and update the sv's end-of-string */
6977         *to = '\0';
6978         SvCUR_set(sv, to - SvPVX(sv));
6979
6980         /*
6981          * this next chunk reads more into the buffer if we're not done yet
6982          */
6983
6984         if (s < PL_bufend)
6985             break;              /* handle case where we are done yet :-) */
6986
6987 #ifndef PERL_STRICT_CR
6988         if (to - SvPVX(sv) >= 2) {
6989             if ((to[-2] == '\r' && to[-1] == '\n') ||
6990                 (to[-2] == '\n' && to[-1] == '\r'))
6991             {
6992                 to[-2] = '\n';
6993                 to--;
6994                 SvCUR_set(sv, to - SvPVX(sv));
6995             }
6996             else if (to[-1] == '\r')
6997                 to[-1] = '\n';
6998         }
6999         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
7000             to[-1] = '\n';
7001 #endif
7002         
7003         /* if we're out of file, or a read fails, bail and reset the current
7004            line marker so we can report where the unterminated string began
7005         */
7006         if (!PL_rsfp ||
7007          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
7008             sv_free(sv);
7009             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
7010             return Nullch;
7011         }
7012         /* we read a line, so increment our line counter */
7013         CopLINE_inc(PL_curcop);
7014
7015         /* update debugger info */
7016         if (PERLDB_LINE && PL_curstash != PL_debstash) {
7017             SV *sv = NEWSV(88,0);
7018
7019             sv_upgrade(sv, SVt_PVMG);
7020             sv_setsv(sv,PL_linestr);
7021             (void)SvIOK_on(sv);
7022             SvIVX(sv) = 0;
7023             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
7024         }
7025
7026         /* having changed the buffer, we must update PL_bufend */
7027         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7028         PL_last_lop = PL_last_uni = Nullch;
7029     }
7030
7031     /* at this point, we have successfully read the delimited string */
7032
7033     if (keep_delims)
7034         sv_catpvn(sv, s, 1);
7035     if (has_utf8)
7036         SvUTF8_on(sv);
7037     PL_multi_end = CopLINE(PL_curcop);
7038     s++;
7039
7040     /* if we allocated too much space, give some back */
7041     if (SvCUR(sv) + 5 < SvLEN(sv)) {
7042         SvLEN_set(sv, SvCUR(sv) + 1);
7043         Renew(SvPVX(sv), SvLEN(sv), char);
7044     }
7045
7046     /* decide whether this is the first or second quoted string we've read
7047        for this op
7048     */
7049
7050     if (PL_lex_stuff)
7051         PL_lex_repl = sv;
7052     else
7053         PL_lex_stuff = sv;
7054     return s;
7055 }
7056
7057 /*
7058   scan_num
7059   takes: pointer to position in buffer
7060   returns: pointer to new position in buffer
7061   side-effects: builds ops for the constant in yylval.op
7062
7063   Read a number in any of the formats that Perl accepts:
7064
7065   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
7066   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
7067   0b[01](_?[01])*
7068   0[0-7](_?[0-7])*
7069   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
7070
7071   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
7072   thing it reads.
7073
7074   If it reads a number without a decimal point or an exponent, it will
7075   try converting the number to an integer and see if it can do so
7076   without loss of precision.
7077 */
7078
7079 char *
7080 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
7081 {
7082     register char *s = start;           /* current position in buffer */
7083     register char *d;                   /* destination in temp buffer */
7084     register char *e;                   /* end of temp buffer */
7085     NV nv;                              /* number read, as a double */
7086     SV *sv = Nullsv;                    /* place to put the converted number */
7087     bool floatit;                       /* boolean: int or float? */
7088     char *lastub = 0;                   /* position of last underbar */
7089     static char number_too_long[] = "Number too long";
7090
7091     /* We use the first character to decide what type of number this is */
7092
7093     switch (*s) {
7094     default:
7095       Perl_croak(aTHX_ "panic: scan_num");
7096
7097     /* if it starts with a 0, it could be an octal number, a decimal in
7098        0.13 disguise, or a hexadecimal number, or a binary number. */
7099     case '0':
7100         {
7101           /* variables:
7102              u          holds the "number so far"
7103              shift      the power of 2 of the base
7104                         (hex == 4, octal == 3, binary == 1)
7105              overflowed was the number more than we can hold?
7106
7107              Shift is used when we add a digit.  It also serves as an "are
7108              we in octal/hex/binary?" indicator to disallow hex characters
7109              when in octal mode.
7110            */
7111             NV n = 0.0;
7112             UV u = 0;
7113             I32 shift;
7114             bool overflowed = FALSE;
7115             static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
7116             static char* bases[5] = { "", "binary", "", "octal",
7117                                       "hexadecimal" };
7118             static char* Bases[5] = { "", "Binary", "", "Octal",
7119                                       "Hexadecimal" };
7120             static char *maxima[5] = { "",
7121                                        "0b11111111111111111111111111111111",
7122                                        "",
7123                                        "037777777777",
7124                                        "0xffffffff" };
7125             char *base, *Base, *max;
7126
7127             /* check for hex */
7128             if (s[1] == 'x') {
7129                 shift = 4;
7130                 s += 2;
7131             } else if (s[1] == 'b') {
7132                 shift = 1;
7133                 s += 2;
7134             }
7135             /* check for a decimal in disguise */
7136             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
7137                 goto decimal;
7138             /* so it must be octal */
7139             else {
7140                 shift = 3;
7141                 s++;
7142             }
7143
7144             if (*s == '_') {
7145                if (ckWARN(WARN_SYNTAX))
7146                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7147                                "Misplaced _ in number");
7148                lastub = s++;
7149             }
7150
7151             base = bases[shift];
7152             Base = Bases[shift];
7153             max  = maxima[shift];
7154
7155             /* read the rest of the number */
7156             for (;;) {
7157                 /* x is used in the overflow test,
7158                    b is the digit we're adding on. */
7159                 UV x, b;
7160
7161                 switch (*s) {
7162
7163                 /* if we don't mention it, we're done */
7164                 default:
7165                     goto out;
7166
7167                 /* _ are ignored -- but warned about if consecutive */
7168                 case '_':
7169                     if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7170                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7171                                     "Misplaced _ in number");
7172                     lastub = s++;
7173                     break;
7174
7175                 /* 8 and 9 are not octal */
7176                 case '8': case '9':
7177                     if (shift == 3)
7178                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7179                     /* FALL THROUGH */
7180
7181                 /* octal digits */
7182                 case '2': case '3': case '4':
7183                 case '5': case '6': case '7':
7184                     if (shift == 1)
7185                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7186                     /* FALL THROUGH */
7187
7188                 case '0': case '1':
7189                     b = *s++ & 15;              /* ASCII digit -> value of digit */
7190                     goto digit;
7191
7192                 /* hex digits */
7193                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7194                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7195                     /* make sure they said 0x */
7196                     if (shift != 4)
7197                         goto out;
7198                     b = (*s++ & 7) + 9;
7199
7200                     /* Prepare to put the digit we have onto the end
7201                        of the number so far.  We check for overflows.
7202                     */
7203
7204                   digit:
7205                     if (!overflowed) {
7206                         x = u << shift; /* make room for the digit */
7207
7208                         if ((x >> shift) != u
7209                             && !(PL_hints & HINT_NEW_BINARY)) {
7210                             overflowed = TRUE;
7211                             n = (NV) u;
7212                             if (ckWARN_d(WARN_OVERFLOW))
7213                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
7214                                             "Integer overflow in %s number",
7215                                             base);
7216                         } else
7217                             u = x | b;          /* add the digit to the end */
7218                     }
7219                     if (overflowed) {
7220                         n *= nvshift[shift];
7221                         /* If an NV has not enough bits in its
7222                          * mantissa to represent an UV this summing of
7223                          * small low-order numbers is a waste of time
7224                          * (because the NV cannot preserve the
7225                          * low-order bits anyway): we could just
7226                          * remember when did we overflow and in the
7227                          * end just multiply n by the right
7228                          * amount. */
7229                         n += (NV) b;
7230                     }
7231                     break;
7232                 }
7233             }
7234
7235           /* if we get here, we had success: make a scalar value from
7236              the number.
7237           */
7238           out:
7239
7240             /* final misplaced underbar check */
7241             if (s[-1] == '_') {
7242                 if (ckWARN(WARN_SYNTAX))
7243                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7244             }
7245
7246             sv = NEWSV(92,0);
7247             if (overflowed) {
7248                 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7249                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7250                                 "%s number > %s non-portable",
7251                                 Base, max);
7252                 sv_setnv(sv, n);
7253             }
7254             else {
7255 #if UVSIZE > 4
7256                 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7257                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7258                                 "%s number > %s non-portable",
7259                                 Base, max);
7260 #endif
7261                 sv_setuv(sv, u);
7262             }
7263             if (PL_hints & HINT_NEW_BINARY)
7264                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7265         }
7266         break;
7267
7268     /*
7269       handle decimal numbers.
7270       we're also sent here when we read a 0 as the first digit
7271     */
7272     case '1': case '2': case '3': case '4': case '5':
7273     case '6': case '7': case '8': case '9': case '.':
7274       decimal:
7275         d = PL_tokenbuf;
7276         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7277         floatit = FALSE;
7278
7279         /* read next group of digits and _ and copy into d */
7280         while (isDIGIT(*s) || *s == '_') {
7281             /* skip underscores, checking for misplaced ones
7282                if -w is on
7283             */
7284             if (*s == '_') {
7285                 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7286                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7287                                 "Misplaced _ in number");
7288                 lastub = s++;
7289             }
7290             else {
7291                 /* check for end of fixed-length buffer */
7292                 if (d >= e)
7293                     Perl_croak(aTHX_ number_too_long);
7294                 /* if we're ok, copy the character */
7295                 *d++ = *s++;
7296             }
7297         }
7298
7299         /* final misplaced underbar check */
7300         if (lastub && s == lastub + 1) {
7301             if (ckWARN(WARN_SYNTAX))
7302                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7303         }
7304
7305         /* read a decimal portion if there is one.  avoid
7306            3..5 being interpreted as the number 3. followed
7307            by .5
7308         */
7309         if (*s == '.' && s[1] != '.') {
7310             floatit = TRUE;
7311             *d++ = *s++;
7312
7313             if (*s == '_') {
7314                 if (ckWARN(WARN_SYNTAX))
7315                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7316                                 "Misplaced _ in number");
7317                 lastub = s;
7318             }
7319
7320             /* copy, ignoring underbars, until we run out of digits.
7321             */
7322             for (; isDIGIT(*s) || *s == '_'; s++) {
7323                 /* fixed length buffer check */
7324                 if (d >= e)
7325                     Perl_croak(aTHX_ number_too_long);
7326                 if (*s == '_') {
7327                    if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7328                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7329                                    "Misplaced _ in number");
7330                    lastub = s;
7331                 }
7332                 else
7333                     *d++ = *s;
7334             }
7335             /* fractional part ending in underbar? */
7336             if (s[-1] == '_') {
7337                 if (ckWARN(WARN_SYNTAX))
7338                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7339                                 "Misplaced _ in number");
7340             }
7341             if (*s == '.' && isDIGIT(s[1])) {
7342                 /* oops, it's really a v-string, but without the "v" */
7343                 s = start;
7344                 goto vstring;
7345             }
7346         }
7347
7348         /* read exponent part, if present */
7349         if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7350             floatit = TRUE;
7351             s++;
7352
7353             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7354             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
7355
7356             /* stray preinitial _ */
7357             if (*s == '_') {
7358                 if (ckWARN(WARN_SYNTAX))
7359                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7360                                 "Misplaced _ in number");
7361                 lastub = s++;
7362             }
7363
7364             /* allow positive or negative exponent */
7365             if (*s == '+' || *s == '-')
7366                 *d++ = *s++;
7367
7368             /* stray initial _ */
7369             if (*s == '_') {
7370                 if (ckWARN(WARN_SYNTAX))
7371                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7372                                 "Misplaced _ in number");
7373                 lastub = s++;
7374             }
7375
7376             /* read digits of exponent */
7377             while (isDIGIT(*s) || *s == '_') {
7378                 if (isDIGIT(*s)) {
7379                     if (d >= e)
7380                         Perl_croak(aTHX_ number_too_long);
7381                     *d++ = *s++;
7382                 }
7383                 else {
7384                    if (ckWARN(WARN_SYNTAX) &&
7385                        ((lastub && s == lastub + 1) ||
7386                         (!isDIGIT(s[1]) && s[1] != '_')))
7387                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7388                                    "Misplaced _ in number");
7389                    lastub = s++;
7390                 }
7391             }
7392         }
7393
7394
7395         /* make an sv from the string */
7396         sv = NEWSV(92,0);
7397
7398         /*
7399            We try to do an integer conversion first if no characters
7400            indicating "float" have been found.
7401          */
7402
7403         if (!floatit) {
7404             UV uv;
7405             int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7406
7407             if (flags == IS_NUMBER_IN_UV) {
7408               if (uv <= IV_MAX)
7409                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7410               else
7411                 sv_setuv(sv, uv);
7412             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7413               if (uv <= (UV) IV_MIN)
7414                 sv_setiv(sv, -(IV)uv);
7415               else
7416                 floatit = TRUE;
7417             } else
7418               floatit = TRUE;
7419         }
7420         if (floatit) {
7421             /* terminate the string */
7422             *d = '\0';
7423             nv = Atof(PL_tokenbuf);
7424             sv_setnv(sv, nv);
7425         }
7426
7427         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7428                        (PL_hints & HINT_NEW_INTEGER) )
7429             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7430                               (floatit ? "float" : "integer"),
7431                               sv, Nullsv, NULL);
7432         break;
7433
7434     /* if it starts with a v, it could be a v-string */
7435     case 'v':
7436 vstring:
7437                 sv = NEWSV(92,5); /* preallocate storage space */
7438                 s = new_vstring(s,sv);
7439         break;
7440     }
7441
7442     /* make the op for the constant and return */
7443
7444     if (sv)
7445         lvalp->opval = newSVOP(OP_CONST, 0, sv);
7446     else
7447         lvalp->opval = Nullop;
7448
7449     return s;
7450 }
7451
7452 STATIC char *
7453 S_scan_formline(pTHX_ register char *s)
7454 {
7455     register char *eol;
7456     register char *t;
7457     SV *stuff = newSVpvn("",0);
7458     bool needargs = FALSE;
7459
7460     while (!needargs) {
7461         if (*s == '.' || *s == /*{*/'}') {
7462             /*SUPPRESS 530*/
7463 #ifdef PERL_STRICT_CR
7464             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7465 #else
7466             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7467 #endif
7468             if (*t == '\n' || t == PL_bufend)
7469                 break;
7470         }
7471         if (PL_in_eval && !PL_rsfp) {
7472             eol = strchr(s,'\n');
7473             if (!eol++)
7474                 eol = PL_bufend;
7475         }
7476         else
7477             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7478         if (*s != '#') {
7479             for (t = s; t < eol; t++) {
7480                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7481                     needargs = FALSE;
7482                     goto enough;        /* ~~ must be first line in formline */
7483                 }
7484                 if (*t == '@' || *t == '^')
7485                     needargs = TRUE;
7486             }
7487             if (eol > s) {
7488                 sv_catpvn(stuff, s, eol-s);
7489 #ifndef PERL_STRICT_CR
7490                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7491                     char *end = SvPVX(stuff) + SvCUR(stuff);
7492                     end[-2] = '\n';
7493                     end[-1] = '\0';
7494                     SvCUR(stuff)--;
7495                 }
7496 #endif
7497             }
7498             else
7499               break;
7500         }
7501         s = eol;
7502         if (PL_rsfp) {
7503             s = filter_gets(PL_linestr, PL_rsfp, 0);
7504             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7505             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7506             PL_last_lop = PL_last_uni = Nullch;
7507             if (!s) {
7508                 s = PL_bufptr;
7509                 yyerror("Format not terminated");
7510                 break;
7511             }
7512         }
7513         incline(s);
7514     }
7515   enough:
7516     if (SvCUR(stuff)) {
7517         PL_expect = XTERM;
7518         if (needargs) {
7519             PL_lex_state = LEX_NORMAL;
7520             PL_nextval[PL_nexttoke].ival = 0;
7521             force_next(',');
7522         }
7523         else
7524             PL_lex_state = LEX_FORMLINE;
7525         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7526         force_next(THING);
7527         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7528         force_next(LSTOP);
7529     }
7530     else {
7531         SvREFCNT_dec(stuff);
7532         PL_lex_formbrack = 0;
7533         PL_bufptr = s;
7534     }
7535     return s;
7536 }
7537
7538 STATIC void
7539 S_set_csh(pTHX)
7540 {
7541 #ifdef CSH
7542     if (!PL_cshlen)
7543         PL_cshlen = strlen(PL_cshname);
7544 #endif
7545 }
7546
7547 I32
7548 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7549 {
7550     I32 oldsavestack_ix = PL_savestack_ix;
7551     CV* outsidecv = PL_compcv;
7552     AV* comppadlist;
7553
7554     if (PL_compcv) {
7555         assert(SvTYPE(PL_compcv) == SVt_PVCV);
7556     }
7557     SAVEI32(PL_subline);
7558     save_item(PL_subname);
7559     SAVEI32(PL_padix);
7560     SAVECOMPPAD();
7561     SAVESPTR(PL_comppad_name);
7562     SAVESPTR(PL_compcv);
7563     SAVEI32(PL_comppad_name_fill);
7564     SAVEI32(PL_min_intro_pending);
7565     SAVEI32(PL_max_intro_pending);
7566     SAVEI32(PL_pad_reset_pending);
7567
7568     PL_compcv = (CV*)NEWSV(1104,0);
7569     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7570     CvFLAGS(PL_compcv) |= flags;
7571
7572     PL_comppad = newAV();
7573     av_push(PL_comppad, Nullsv);
7574     PL_curpad = AvARRAY(PL_comppad);
7575     PL_comppad_name = newAV();
7576     PL_comppad_name_fill = 0;
7577     PL_min_intro_pending = 0;
7578     PL_padix = 0;
7579     PL_subline = CopLINE(PL_curcop);
7580 #ifdef USE_5005THREADS
7581     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
7582     PL_curpad[0] = (SV*)newAV();
7583     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
7584 #endif /* USE_5005THREADS */
7585
7586     comppadlist = newAV();
7587     AvREAL_off(comppadlist);
7588     av_store(comppadlist, 0, (SV*)PL_comppad_name);
7589     av_store(comppadlist, 1, (SV*)PL_comppad);
7590
7591     CvPADLIST(PL_compcv) = comppadlist;
7592     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7593 #ifdef USE_5005THREADS
7594     CvOWNER(PL_compcv) = 0;
7595     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
7596     MUTEX_INIT(CvMUTEXP(PL_compcv));
7597 #endif /* USE_5005THREADS */
7598
7599     return oldsavestack_ix;
7600 }
7601
7602 #ifdef __SC__
7603 #pragma segment Perl_yylex
7604 #endif
7605 int
7606 Perl_yywarn(pTHX_ char *s)
7607 {
7608     PL_in_eval |= EVAL_WARNONLY;
7609     yyerror(s);
7610     PL_in_eval &= ~EVAL_WARNONLY;
7611     return 0;
7612 }
7613
7614 int
7615 Perl_yyerror(pTHX_ char *s)
7616 {
7617     char *where = NULL;
7618     char *context = NULL;
7619     int contlen = -1;
7620     SV *msg;
7621
7622     if (!yychar || (yychar == ';' && !PL_rsfp))
7623         where = "at EOF";
7624     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7625       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7626         /*
7627                 Only for NetWare:
7628                 The code below is removed for NetWare because it abends/crashes on NetWare
7629                 when the script has error such as not having the closing quotes like:
7630                     if ($var eq "value)
7631                 Checking of white spaces is anyway done in NetWare code.
7632         */
7633 #ifndef NETWARE
7634         while (isSPACE(*PL_oldoldbufptr))
7635             PL_oldoldbufptr++;
7636 #endif
7637         context = PL_oldoldbufptr;
7638         contlen = PL_bufptr - PL_oldoldbufptr;
7639     }
7640     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7641       PL_oldbufptr != PL_bufptr) {
7642         /*
7643                 Only for NetWare:
7644                 The code below is removed for NetWare because it abends/crashes on NetWare
7645                 when the script has error such as not having the closing quotes like:
7646                     if ($var eq "value)
7647                 Checking of white spaces is anyway done in NetWare code.
7648         */
7649 #ifndef NETWARE
7650         while (isSPACE(*PL_oldbufptr))
7651             PL_oldbufptr++;
7652 #endif
7653         context = PL_oldbufptr;
7654         contlen = PL_bufptr - PL_oldbufptr;
7655     }
7656     else if (yychar > 255)
7657         where = "next token ???";
7658 #ifdef USE_PURE_BISON
7659 /*  GNU Bison sets the value -2 */
7660     else if (yychar == -2) {
7661 #else
7662     else if ((yychar & 127) == 127) {
7663 #endif
7664         if (PL_lex_state == LEX_NORMAL ||
7665            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7666             where = "at end of line";
7667         else if (PL_lex_inpat)
7668             where = "within pattern";
7669         else
7670             where = "within string";
7671     }
7672     else {
7673         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7674         if (yychar < 32)
7675             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7676         else if (isPRINT_LC(yychar))
7677             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7678         else
7679             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7680         where = SvPVX(where_sv);
7681     }
7682     msg = sv_2mortal(newSVpv(s, 0));
7683     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7684         OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7685     if (context)
7686         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7687     else
7688         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7689     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7690         Perl_sv_catpvf(aTHX_ msg,
7691         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7692                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7693         PL_multi_end = 0;
7694     }
7695     if (PL_in_eval & EVAL_WARNONLY)
7696         Perl_warn(aTHX_ "%"SVf, msg);
7697     else
7698         qerror(msg);
7699     if (PL_error_count >= 10) {
7700         if (PL_in_eval && SvCUR(ERRSV))
7701             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7702             ERRSV, OutCopFILE(PL_curcop));
7703         else
7704             Perl_croak(aTHX_ "%s has too many errors.\n",
7705             OutCopFILE(PL_curcop));
7706     }
7707     PL_in_my = 0;
7708     PL_in_my_stash = Nullhv;
7709     return 0;
7710 }
7711 #ifdef __SC__
7712 #pragma segment Main
7713 #endif
7714
7715 STATIC char*
7716 S_swallow_bom(pTHX_ U8 *s)
7717 {
7718     STRLEN slen;
7719     slen = SvCUR(PL_linestr);
7720     switch (*s) {
7721     case 0xFF:
7722         if (s[1] == 0xFE) {
7723             /* UTF-16 little-endian */
7724             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
7725                 Perl_croak(aTHX_ "Unsupported script encoding");
7726 #ifndef PERL_NO_UTF16_FILTER
7727             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7728             s += 2;
7729             if (PL_bufend > (char*)s) {
7730                 U8 *news;
7731                 I32 newlen;
7732
7733                 filter_add(utf16rev_textfilter, NULL);
7734                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7735                 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7736                                                  PL_bufend - (char*)s - 1,
7737                                                  &newlen);
7738                 Copy(news, s, newlen, U8);
7739                 SvCUR_set(PL_linestr, newlen);
7740                 PL_bufend = SvPVX(PL_linestr) + newlen;
7741                 news[newlen++] = '\0';
7742                 Safefree(news);
7743             }
7744 #else
7745             Perl_croak(aTHX_ "Unsupported script encoding");
7746 #endif
7747         }
7748         break;
7749     case 0xFE:
7750         if (s[1] == 0xFF) {   /* UTF-16 big-endian */
7751 #ifndef PERL_NO_UTF16_FILTER
7752             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7753             s += 2;
7754             if (PL_bufend > (char *)s) {
7755                 U8 *news;
7756                 I32 newlen;
7757
7758                 filter_add(utf16_textfilter, NULL);
7759                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7760                 PL_bufend = (char*)utf16_to_utf8(s, news,
7761                                                  PL_bufend - (char*)s,
7762                                                  &newlen);
7763                 Copy(news, s, newlen, U8);
7764                 SvCUR_set(PL_linestr, newlen);
7765                 PL_bufend = SvPVX(PL_linestr) + newlen;
7766                 news[newlen++] = '\0';
7767                 Safefree(news);
7768             }
7769 #else
7770             Perl_croak(aTHX_ "Unsupported script encoding");
7771 #endif
7772         }
7773         break;
7774     case 0xEF:
7775         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7776             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7777             s += 3;                      /* UTF-8 */
7778         }
7779         break;
7780     case 0:
7781         if (slen > 3 && s[1] == 0 &&  /* UTF-32 big-endian */
7782             s[2] == 0xFE && s[3] == 0xFF)
7783         {
7784             Perl_croak(aTHX_ "Unsupported script encoding");
7785         }
7786     }
7787     return (char*)s;
7788 }
7789
7790 /*
7791  * restore_rsfp
7792  * Restore a source filter.
7793  */
7794
7795 static void
7796 restore_rsfp(pTHX_ void *f)
7797 {
7798     PerlIO *fp = (PerlIO*)f;
7799
7800     if (PL_rsfp == PerlIO_stdin())
7801         PerlIO_clearerr(PL_rsfp);
7802     else if (PL_rsfp && (PL_rsfp != fp))
7803         PerlIO_close(PL_rsfp);
7804     PL_rsfp = fp;
7805 }
7806
7807 #ifndef PERL_NO_UTF16_FILTER
7808 static I32
7809 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7810 {
7811     I32 count = FILTER_READ(idx+1, sv, maxlen);
7812     if (count) {
7813         U8* tmps;
7814         U8* tend;
7815         I32 newlen;
7816         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7817         if (!*SvPV_nolen(sv))
7818         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7819         return count;
7820
7821         tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7822         sv_usepvn(sv, (char*)tmps, tend - tmps);
7823     }
7824     return count;
7825 }
7826
7827 static I32
7828 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7829 {
7830     I32 count = FILTER_READ(idx+1, sv, maxlen);
7831     if (count) {
7832         U8* tmps;
7833         U8* tend;
7834         I32 newlen;
7835         if (!*SvPV_nolen(sv))
7836         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7837         return count;
7838
7839         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7840         tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7841         sv_usepvn(sv, (char*)tmps, tend - tmps);
7842     }
7843     return count;
7844 }
7845 #endif
7846