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