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