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