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