This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
e131eb254210c84dcc36d2cf102438b111dfe7b5
[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")", 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 %d [", 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             SvIVX(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                 SvNVX(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         SvLEN_set(sv, SvCUR(sv) + 1);
1829         Renew(SvPVX(sv), SvLEN(sv), char);
1830     }
1831
1832     /* return the substring (via yylval) only if we parsed anything */
1833     if (s > PL_bufptr) {
1834         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1835             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1836                               sv, Nullsv,
1837                               ( PL_lex_inwhat == OP_TRANS
1838                                 ? "tr"
1839                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1840                                     ? "s"
1841                                     : "qq")));
1842         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1843     } else
1844         SvREFCNT_dec(sv);
1845     return s;
1846 }
1847
1848 /* S_intuit_more
1849  * Returns TRUE if there's more to the expression (e.g., a subscript),
1850  * FALSE otherwise.
1851  *
1852  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1853  *
1854  * ->[ and ->{ return TRUE
1855  * { and [ outside a pattern are always subscripts, so return TRUE
1856  * if we're outside a pattern and it's not { or [, then return FALSE
1857  * if we're in a pattern and the first char is a {
1858  *   {4,5} (any digits around the comma) returns FALSE
1859  * if we're in a pattern and the first char is a [
1860  *   [] returns FALSE
1861  *   [SOMETHING] has a funky algorithm to decide whether it's a
1862  *      character class or not.  It has to deal with things like
1863  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1864  * anything else returns TRUE
1865  */
1866
1867 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1868
1869 STATIC int
1870 S_intuit_more(pTHX_ register char *s)
1871 {
1872     if (PL_lex_brackets)
1873         return TRUE;
1874     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1875         return TRUE;
1876     if (*s != '{' && *s != '[')
1877         return FALSE;
1878     if (!PL_lex_inpat)
1879         return TRUE;
1880
1881     /* In a pattern, so maybe we have {n,m}. */
1882     if (*s == '{') {
1883         s++;
1884         if (!isDIGIT(*s))
1885             return TRUE;
1886         while (isDIGIT(*s))
1887             s++;
1888         if (*s == ',')
1889             s++;
1890         while (isDIGIT(*s))
1891             s++;
1892         if (*s == '}')
1893             return FALSE;
1894         return TRUE;
1895         
1896     }
1897
1898     /* On the other hand, maybe we have a character class */
1899
1900     s++;
1901     if (*s == ']' || *s == '^')
1902         return FALSE;
1903     else {
1904         /* this is terrifying, and it works */
1905         int weight = 2;         /* let's weigh the evidence */
1906         char seen[256];
1907         unsigned char un_char = 255, last_un_char;
1908         char *send = strchr(s,']');
1909         char tmpbuf[sizeof PL_tokenbuf * 4];
1910
1911         if (!send)              /* has to be an expression */
1912             return TRUE;
1913
1914         Zero(seen,256,char);
1915         if (*s == '$')
1916             weight -= 3;
1917         else if (isDIGIT(*s)) {
1918             if (s[1] != ']') {
1919                 if (isDIGIT(s[1]) && s[2] == ']')
1920                     weight -= 10;
1921             }
1922             else
1923                 weight -= 100;
1924         }
1925         for (; s < send; s++) {
1926             last_un_char = un_char;
1927             un_char = (unsigned char)*s;
1928             switch (*s) {
1929             case '@':
1930             case '&':
1931             case '$':
1932                 weight -= seen[un_char] * 10;
1933                 if (isALNUM_lazy_if(s+1,UTF)) {
1934                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1935                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1936                         weight -= 100;
1937                     else
1938                         weight -= 10;
1939                 }
1940                 else if (*s == '$' && s[1] &&
1941                   strchr("[#!%*<>()-=",s[1])) {
1942                     if (/*{*/ strchr("])} =",s[2]))
1943                         weight -= 10;
1944                     else
1945                         weight -= 1;
1946                 }
1947                 break;
1948             case '\\':
1949                 un_char = 254;
1950                 if (s[1]) {
1951                     if (strchr("wds]",s[1]))
1952                         weight += 100;
1953                     else if (seen['\''] || seen['"'])
1954                         weight += 1;
1955                     else if (strchr("rnftbxcav",s[1]))
1956                         weight += 40;
1957                     else if (isDIGIT(s[1])) {
1958                         weight += 40;
1959                         while (s[1] && isDIGIT(s[1]))
1960                             s++;
1961                     }
1962                 }
1963                 else
1964                     weight += 100;
1965                 break;
1966             case '-':
1967                 if (s[1] == '\\')
1968                     weight += 50;
1969                 if (strchr("aA01! ",last_un_char))
1970                     weight += 30;
1971                 if (strchr("zZ79~",s[1]))
1972                     weight += 30;
1973                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1974                     weight -= 5;        /* cope with negative subscript */
1975                 break;
1976             default:
1977                 if (!isALNUM(last_un_char)
1978                     && !(last_un_char == '$' || last_un_char == '@'
1979                          || last_un_char == '&')
1980                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
1981                     char *d = tmpbuf;
1982                     while (isALPHA(*s))
1983                         *d++ = *s++;
1984                     *d = '\0';
1985                     if (keyword(tmpbuf, d - tmpbuf))
1986                         weight -= 150;
1987                 }
1988                 if (un_char == last_un_char + 1)
1989                     weight += 5;
1990                 weight -= seen[un_char];
1991                 break;
1992             }
1993             seen[un_char]++;
1994         }
1995         if (weight >= 0)        /* probably a character class */
1996             return FALSE;
1997     }
1998
1999     return TRUE;
2000 }
2001
2002 /*
2003  * S_intuit_method
2004  *
2005  * Does all the checking to disambiguate
2006  *   foo bar
2007  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
2008  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2009  *
2010  * First argument is the stuff after the first token, e.g. "bar".
2011  *
2012  * Not a method if bar is a filehandle.
2013  * Not a method if foo is a subroutine prototyped to take a filehandle.
2014  * Not a method if it's really "Foo $bar"
2015  * Method if it's "foo $bar"
2016  * Not a method if it's really "print foo $bar"
2017  * Method if it's really "foo package::" (interpreted as package->foo)
2018  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2019  * Not a method if bar is a filehandle or package, but is quoted with
2020  *   =>
2021  */
2022
2023 STATIC int
2024 S_intuit_method(pTHX_ char *start, GV *gv)
2025 {
2026     char *s = start + (*start == '$');
2027     char tmpbuf[sizeof PL_tokenbuf];
2028     STRLEN len;
2029     GV* indirgv;
2030
2031     if (gv) {
2032         CV *cv;
2033         if (GvIO(gv))
2034             return 0;
2035         if ((cv = GvCVu(gv))) {
2036             char *proto = SvPVX(cv);
2037             if (proto) {
2038                 if (*proto == ';')
2039                     proto++;
2040                 if (*proto == '*')
2041                     return 0;
2042             }
2043         } else
2044             gv = 0;
2045     }
2046     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2047     /* start is the beginning of the possible filehandle/object,
2048      * and s is the end of it
2049      * tmpbuf is a copy of it
2050      */
2051
2052     if (*start == '$') {
2053         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2054             return 0;
2055         s = skipspace(s);
2056         PL_bufptr = start;
2057         PL_expect = XREF;
2058         return *s == '(' ? FUNCMETH : METHOD;
2059     }
2060     if (!keyword(tmpbuf, len)) {
2061         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2062             len -= 2;
2063             tmpbuf[len] = '\0';
2064             goto bare_package;
2065         }
2066         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2067         if (indirgv && GvCVu(indirgv))
2068             return 0;
2069         /* filehandle or package name makes it a method */
2070         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2071             s = skipspace(s);
2072             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2073                 return 0;       /* no assumptions -- "=>" quotes bearword */
2074       bare_package:
2075             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
2076                                                    newSVpvn(tmpbuf,len));
2077             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
2078             PL_expect = XTERM;
2079             force_next(WORD);
2080             PL_bufptr = s;
2081             return *s == '(' ? FUNCMETH : METHOD;
2082         }
2083     }
2084     return 0;
2085 }
2086
2087 /*
2088  * S_incl_perldb
2089  * Return a string of Perl code to load the debugger.  If PERL5DB
2090  * is set, it will return the contents of that, otherwise a
2091  * compile-time require of perl5db.pl.
2092  */
2093
2094 STATIC const char*
2095 S_incl_perldb(pTHX)
2096 {
2097     if (PL_perldb) {
2098         const char *pdb = PerlEnv_getenv("PERL5DB");
2099
2100         if (pdb)
2101             return pdb;
2102         SETERRNO(0,SS_NORMAL);
2103         return "BEGIN { require 'perl5db.pl' }";
2104     }
2105     return "";
2106 }
2107
2108
2109 /* Encoded script support. filter_add() effectively inserts a
2110  * 'pre-processing' function into the current source input stream.
2111  * Note that the filter function only applies to the current source file
2112  * (e.g., it will not affect files 'require'd or 'use'd by this one).
2113  *
2114  * The datasv parameter (which may be NULL) can be used to pass
2115  * private data to this instance of the filter. The filter function
2116  * can recover the SV using the FILTER_DATA macro and use it to
2117  * store private buffers and state information.
2118  *
2119  * The supplied datasv parameter is upgraded to a PVIO type
2120  * and the IoDIRP/IoANY field is used to store the function pointer,
2121  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2122  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2123  * private use must be set using malloc'd pointers.
2124  */
2125
2126 SV *
2127 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2128 {
2129     if (!funcp)
2130         return Nullsv;
2131
2132     if (!PL_rsfp_filters)
2133         PL_rsfp_filters = newAV();
2134     if (!datasv)
2135         datasv = NEWSV(255,0);
2136     if (!SvUPGRADE(datasv, SVt_PVIO))
2137         Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
2138     IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
2139     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2140     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2141                           (void*)funcp, SvPV_nolen(datasv)));
2142     av_unshift(PL_rsfp_filters, 1);
2143     av_store(PL_rsfp_filters, 0, datasv) ;
2144     return(datasv);
2145 }
2146
2147
2148 /* Delete most recently added instance of this filter function. */
2149 void
2150 Perl_filter_del(pTHX_ filter_t funcp)
2151 {
2152     SV *datasv;
2153     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
2154     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2155         return;
2156     /* if filter is on top of stack (usual case) just pop it off */
2157     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2158     if (IoANY(datasv) == (void *)funcp) {
2159         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2160         IoANY(datasv) = (void *)NULL;
2161         sv_free(av_pop(PL_rsfp_filters));
2162
2163         return;
2164     }
2165     /* we need to search for the correct entry and clear it     */
2166     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2167 }
2168
2169
2170 /* Invoke the idxth filter function for the current rsfp.        */
2171 /* maxlen 0 = read one text line */
2172 I32
2173 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2174 {
2175     filter_t funcp;
2176     SV *datasv = NULL;
2177
2178     if (!PL_rsfp_filters)
2179         return -1;
2180     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
2181         /* Provide a default input filter to make life easy.    */
2182         /* Note that we append to the line. This is handy.      */
2183         DEBUG_P(PerlIO_printf(Perl_debug_log,
2184                               "filter_read %d: from rsfp\n", idx));
2185         if (maxlen) {
2186             /* Want a block */
2187             int len ;
2188             int old_len = SvCUR(buf_sv) ;
2189
2190             /* ensure buf_sv is large enough */
2191             SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2192             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2193                 if (PerlIO_error(PL_rsfp))
2194                     return -1;          /* error */
2195                 else
2196                     return 0 ;          /* end of file */
2197             }
2198             SvCUR_set(buf_sv, old_len + len) ;
2199         } else {
2200             /* Want a line */
2201             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2202                 if (PerlIO_error(PL_rsfp))
2203                     return -1;          /* error */
2204                 else
2205                     return 0 ;          /* end of file */
2206             }
2207         }
2208         return SvCUR(buf_sv);
2209     }
2210     /* Skip this filter slot if filter has been deleted */
2211     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2212         DEBUG_P(PerlIO_printf(Perl_debug_log,
2213                               "filter_read %d: skipped (filter deleted)\n",
2214                               idx));
2215         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2216     }
2217     /* Get function pointer hidden within datasv        */
2218     funcp = (filter_t)IoANY(datasv);
2219     DEBUG_P(PerlIO_printf(Perl_debug_log,
2220                           "filter_read %d: via function %p (%s)\n",
2221                           idx, (void*)funcp, SvPV_nolen(datasv)));
2222     /* Call function. The function is expected to       */
2223     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2224     /* Return: <0:error, =0:eof, >0:not eof             */
2225     return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2226 }
2227
2228 STATIC char *
2229 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2230 {
2231 #ifdef PERL_CR_FILTER
2232     if (!PL_rsfp_filters) {
2233         filter_add(S_cr_textfilter,NULL);
2234     }
2235 #endif
2236     if (PL_rsfp_filters) {
2237         if (!append)
2238             SvCUR_set(sv, 0);   /* start with empty line        */
2239         if (FILTER_READ(0, sv, 0) > 0)
2240             return ( SvPVX(sv) ) ;
2241         else
2242             return Nullch ;
2243     }
2244     else
2245         return (sv_gets(sv, fp, append));
2246 }
2247
2248 STATIC HV *
2249 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2250 {
2251     GV *gv;
2252
2253     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2254         return PL_curstash;
2255
2256     if (len > 2 &&
2257         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2258         (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2259     {
2260         return GvHV(gv);                        /* Foo:: */
2261     }
2262
2263     /* use constant CLASS => 'MyClass' */
2264     if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2265         SV *sv;
2266         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2267             pkgname = SvPV_nolen(sv);
2268         }
2269     }
2270
2271     return gv_stashpv(pkgname, FALSE);
2272 }
2273
2274 #ifdef DEBUGGING
2275     static char const* exp_name[] =
2276         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2277           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2278         };
2279 #endif
2280
2281 /*
2282   yylex
2283
2284   Works out what to call the token just pulled out of the input
2285   stream.  The yacc parser takes care of taking the ops we return and
2286   stitching them into a tree.
2287
2288   Returns:
2289     PRIVATEREF
2290
2291   Structure:
2292       if read an identifier
2293           if we're in a my declaration
2294               croak if they tried to say my($foo::bar)
2295               build the ops for a my() declaration
2296           if it's an access to a my() variable
2297               are we in a sort block?
2298                   croak if my($a); $a <=> $b
2299               build ops for access to a my() variable
2300           if in a dq string, and they've said @foo and we can't find @foo
2301               croak
2302           build ops for a bareword
2303       if we already built the token before, use it.
2304 */
2305
2306
2307 #ifdef __SC__
2308 #pragma segment Perl_yylex
2309 #endif
2310 int
2311 Perl_yylex(pTHX)
2312 {
2313     register char *s = PL_bufptr;
2314     register char *d;
2315     register I32 tmp;
2316     STRLEN len;
2317     GV *gv = Nullgv;
2318     GV **gvp = 0;
2319     bool bof = FALSE;
2320     I32 orig_keyword = 0;
2321
2322     DEBUG_T( {
2323         PerlIO_printf(Perl_debug_log, "### LEX_%s\n",
2324                                         lex_state_names[PL_lex_state]);
2325     } );
2326     /* check if there's an identifier for us to look at */
2327     if (PL_pending_ident)
2328         return REPORT(S_pending_ident(aTHX));
2329
2330     /* no identifier pending identification */
2331
2332     switch (PL_lex_state) {
2333 #ifdef COMMENTARY
2334     case LEX_NORMAL:            /* Some compilers will produce faster */
2335     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2336         break;
2337 #endif
2338
2339     /* when we've already built the next token, just pull it out of the queue */
2340     case LEX_KNOWNEXT:
2341         PL_nexttoke--;
2342         yylval = PL_nextval[PL_nexttoke];
2343         if (!PL_nexttoke) {
2344             PL_lex_state = PL_lex_defer;
2345             PL_expect = PL_lex_expect;
2346             PL_lex_defer = LEX_NORMAL;
2347         }
2348         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2349               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2350               (IV)PL_nexttype[PL_nexttoke]); });
2351
2352         return REPORT(PL_nexttype[PL_nexttoke]);
2353
2354     /* interpolated case modifiers like \L \U, including \Q and \E.
2355        when we get here, PL_bufptr is at the \
2356     */
2357     case LEX_INTERPCASEMOD:
2358 #ifdef DEBUGGING
2359         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2360             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2361 #endif
2362         /* handle \E or end of string */
2363         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2364             char oldmod;
2365
2366             /* if at a \E */
2367             if (PL_lex_casemods) {
2368                 oldmod = PL_lex_casestack[--PL_lex_casemods];
2369                 PL_lex_casestack[PL_lex_casemods] = '\0';
2370
2371                 if (PL_bufptr != PL_bufend
2372                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
2373                     PL_bufptr += 2;
2374                     PL_lex_state = LEX_INTERPCONCAT;
2375                 }
2376                 return REPORT(')');
2377             }
2378             if (PL_bufptr != PL_bufend)
2379                 PL_bufptr += 2;
2380             PL_lex_state = LEX_INTERPCONCAT;
2381             return yylex();
2382         }
2383         else {
2384             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2385               "### Saw case modifier at '%s'\n", PL_bufptr); });
2386             s = PL_bufptr + 1;
2387             if (s[1] == '\\' && s[2] == 'E') {
2388                 PL_bufptr = s + 3;
2389                 PL_lex_state = LEX_INTERPCONCAT;
2390                 return yylex();
2391             }
2392             else {
2393                 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2394                     tmp = *s, *s = s[2], s[2] = (char)tmp;      /* misordered... */
2395                 if ((*s == 'L' || *s == 'U') &&
2396                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2397                     PL_lex_casestack[--PL_lex_casemods] = '\0';
2398                     return REPORT(')');
2399                 }
2400                 if (PL_lex_casemods > 10)
2401                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2402                 PL_lex_casestack[PL_lex_casemods++] = *s;
2403                 PL_lex_casestack[PL_lex_casemods] = '\0';
2404                 PL_lex_state = LEX_INTERPCONCAT;
2405                 PL_nextval[PL_nexttoke].ival = 0;
2406                 force_next('(');
2407                 if (*s == 'l')
2408                     PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2409                 else if (*s == 'u')
2410                     PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2411                 else if (*s == 'L')
2412                     PL_nextval[PL_nexttoke].ival = OP_LC;
2413                 else if (*s == 'U')
2414                     PL_nextval[PL_nexttoke].ival = OP_UC;
2415                 else if (*s == 'Q')
2416                     PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2417                 else
2418                     Perl_croak(aTHX_ "panic: yylex");
2419                 PL_bufptr = s + 1;
2420             }
2421             force_next(FUNC);
2422             if (PL_lex_starts) {
2423                 s = PL_bufptr;
2424                 PL_lex_starts = 0;
2425                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2426                 if (PL_lex_casemods == 1 && PL_lex_inpat)
2427                     OPERATOR(',');
2428                 else
2429                     Aop(OP_CONCAT);
2430             }
2431             else
2432                 return yylex();
2433         }
2434
2435     case LEX_INTERPPUSH:
2436         return REPORT(sublex_push());
2437
2438     case LEX_INTERPSTART:
2439         if (PL_bufptr == PL_bufend)
2440             return REPORT(sublex_done());
2441         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2442               "### Interpolated variable at '%s'\n", PL_bufptr); });
2443         PL_expect = XTERM;
2444         PL_lex_dojoin = (*PL_bufptr == '@');
2445         PL_lex_state = LEX_INTERPNORMAL;
2446         if (PL_lex_dojoin) {
2447             PL_nextval[PL_nexttoke].ival = 0;
2448             force_next(',');
2449             force_ident("\"", '$');
2450             PL_nextval[PL_nexttoke].ival = 0;
2451             force_next('$');
2452             PL_nextval[PL_nexttoke].ival = 0;
2453             force_next('(');
2454             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2455             force_next(FUNC);
2456         }
2457         if (PL_lex_starts++) {
2458             s = PL_bufptr;
2459             /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2460             if (!PL_lex_casemods && PL_lex_inpat)
2461                 OPERATOR(',');
2462             else
2463                 Aop(OP_CONCAT);
2464         }
2465         return yylex();
2466
2467     case LEX_INTERPENDMAYBE:
2468         if (intuit_more(PL_bufptr)) {
2469             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2470             break;
2471         }
2472         /* FALL THROUGH */
2473
2474     case LEX_INTERPEND:
2475         if (PL_lex_dojoin) {
2476             PL_lex_dojoin = FALSE;
2477             PL_lex_state = LEX_INTERPCONCAT;
2478             return REPORT(')');
2479         }
2480         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2481             && SvEVALED(PL_lex_repl))
2482         {
2483             if (PL_bufptr != PL_bufend)
2484                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2485             PL_lex_repl = Nullsv;
2486         }
2487         /* FALLTHROUGH */
2488     case LEX_INTERPCONCAT:
2489 #ifdef DEBUGGING
2490         if (PL_lex_brackets)
2491             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2492 #endif
2493         if (PL_bufptr == PL_bufend)
2494             return REPORT(sublex_done());
2495
2496         if (SvIVX(PL_linestr) == '\'') {
2497             SV *sv = newSVsv(PL_linestr);
2498             if (!PL_lex_inpat)
2499                 sv = tokeq(sv);
2500             else if ( PL_hints & HINT_NEW_RE )
2501                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2502             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2503             s = PL_bufend;
2504         }
2505         else {
2506             s = scan_const(PL_bufptr);
2507             if (*s == '\\')
2508                 PL_lex_state = LEX_INTERPCASEMOD;
2509             else
2510                 PL_lex_state = LEX_INTERPSTART;
2511         }
2512
2513         if (s != PL_bufptr) {
2514             PL_nextval[PL_nexttoke] = yylval;
2515             PL_expect = XTERM;
2516             force_next(THING);
2517             if (PL_lex_starts++) {
2518                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
2519                 if (!PL_lex_casemods && PL_lex_inpat)
2520                     OPERATOR(',');
2521                 else
2522                     Aop(OP_CONCAT);
2523             }
2524             else {
2525                 PL_bufptr = s;
2526                 return yylex();
2527             }
2528         }
2529
2530         return yylex();
2531     case LEX_FORMLINE:
2532         PL_lex_state = LEX_NORMAL;
2533         s = scan_formline(PL_bufptr);
2534         if (!PL_lex_formbrack)
2535             goto rightbracket;
2536         OPERATOR(';');
2537     }
2538
2539     s = PL_bufptr;
2540     PL_oldoldbufptr = PL_oldbufptr;
2541     PL_oldbufptr = s;
2542     DEBUG_T( {
2543         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n",
2544                       exp_name[PL_expect], s);
2545     } );
2546
2547   retry:
2548     switch (*s) {
2549     default:
2550         if (isIDFIRST_lazy_if(s,UTF))
2551             goto keylookup;
2552         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2553     case 4:
2554     case 26:
2555         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2556     case 0:
2557         if (!PL_rsfp) {
2558             PL_last_uni = 0;
2559             PL_last_lop = 0;
2560             if (PL_lex_brackets) {
2561                 if (PL_lex_formbrack)
2562                     yyerror("Format not terminated");
2563                 else
2564                     yyerror("Missing right curly or square bracket");
2565             }
2566             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2567                         "### Tokener got EOF\n");
2568             } );
2569             TOKEN(0);
2570         }
2571         if (s++ < PL_bufend)
2572             goto retry;                 /* ignore stray nulls */
2573         PL_last_uni = 0;
2574         PL_last_lop = 0;
2575         if (!PL_in_eval && !PL_preambled) {
2576             PL_preambled = TRUE;
2577             sv_setpv(PL_linestr,incl_perldb());
2578             if (SvCUR(PL_linestr))
2579                 sv_catpvn(PL_linestr,";", 1);
2580             if (PL_preambleav){
2581                 while(AvFILLp(PL_preambleav) >= 0) {
2582                     SV *tmpsv = av_shift(PL_preambleav);
2583                     sv_catsv(PL_linestr, tmpsv);
2584                     sv_catpvn(PL_linestr, ";", 1);
2585                     sv_free(tmpsv);
2586                 }
2587                 sv_free((SV*)PL_preambleav);
2588                 PL_preambleav = NULL;
2589             }
2590             if (PL_minus_n || PL_minus_p) {
2591                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2592                 if (PL_minus_l)
2593                     sv_catpv(PL_linestr,"chomp;");
2594                 if (PL_minus_a) {
2595                     if (PL_minus_F) {
2596                         if ((*PL_splitstr == '/' || *PL_splitstr == '\''
2597                              || *PL_splitstr == '"')
2598                               && strchr(PL_splitstr + 1, *PL_splitstr))
2599                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2600                         else {
2601                             /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
2602                                bytes can be used as quoting characters.  :-) */
2603                             /* The count here deliberately includes the NUL
2604                                that terminates the C string constant.  This
2605                                embeds the opening NUL into the string.  */
2606                             sv_catpvn(PL_linestr, "our @F=split(q", 15);
2607                             s = PL_splitstr;
2608                             do {
2609                                 /* Need to \ \s  */
2610                                 if (*s == '\\')
2611                                     sv_catpvn(PL_linestr, s, 1);
2612                                 sv_catpvn(PL_linestr, s, 1);
2613                             } while (*s++);
2614                             /* This loop will embed the trailing NUL of
2615                                PL_linestr as the last thing it does before
2616                                terminating.  */
2617                             sv_catpvn(PL_linestr, ");", 2);
2618                         }
2619                     }
2620                     else
2621                         sv_catpv(PL_linestr,"our @F=split(' ');");
2622                 }
2623             }
2624             sv_catpvn(PL_linestr, "\n", 1);
2625             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2626             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2627             PL_last_lop = PL_last_uni = Nullch;
2628             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2629                 SV *sv = NEWSV(85,0);
2630
2631                 sv_upgrade(sv, SVt_PVMG);
2632                 sv_setsv(sv,PL_linestr);
2633                 (void)SvIOK_on(sv);
2634                 SvIVX(sv) = 0;
2635                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2636             }
2637             goto retry;
2638         }
2639         do {
2640             bof = PL_rsfp ? TRUE : FALSE;
2641             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2642               fake_eof:
2643                 if (PL_rsfp) {
2644                     if (PL_preprocess && !PL_in_eval)
2645                         (void)PerlProc_pclose(PL_rsfp);
2646                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2647                         PerlIO_clearerr(PL_rsfp);
2648                     else
2649                         (void)PerlIO_close(PL_rsfp);
2650                     PL_rsfp = Nullfp;
2651                     PL_doextract = FALSE;
2652                 }
2653                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2654                     sv_setpv(PL_linestr,PL_minus_p
2655                              ? ";}continue{print;}" : ";}");
2656                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2657                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2658                     PL_last_lop = PL_last_uni = Nullch;
2659                     PL_minus_n = PL_minus_p = 0;
2660                     goto retry;
2661                 }
2662                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2663                 PL_last_lop = PL_last_uni = Nullch;
2664                 sv_setpv(PL_linestr,"");
2665                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2666             }
2667             /* If it looks like the start of a BOM or raw UTF-16,
2668              * check if it in fact is. */
2669             else if (bof &&
2670                      (*s == 0 ||
2671                       *(U8*)s == 0xEF ||
2672                       *(U8*)s >= 0xFE ||
2673                       s[1] == 0)) {
2674 #ifdef PERLIO_IS_STDIO
2675 #  ifdef __GNU_LIBRARY__
2676 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2677 #      define FTELL_FOR_PIPE_IS_BROKEN
2678 #    endif
2679 #  else
2680 #    ifdef __GLIBC__
2681 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2682 #        define FTELL_FOR_PIPE_IS_BROKEN
2683 #      endif
2684 #    endif
2685 #  endif
2686 #endif
2687 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2688                 /* This loses the possibility to detect the bof
2689                  * situation on perl -P when the libc5 is being used.
2690                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2691                  */
2692                 if (!PL_preprocess)
2693                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2694 #else
2695                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2696 #endif
2697                 if (bof) {
2698                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2699                     s = swallow_bom((U8*)s);
2700                 }
2701             }
2702             if (PL_doextract) {
2703                 /* Incest with pod. */
2704                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2705                     sv_setpv(PL_linestr, "");
2706                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2707                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2708                     PL_last_lop = PL_last_uni = Nullch;
2709                     PL_doextract = FALSE;
2710                 }
2711             }
2712             incline(s);
2713         } while (PL_doextract);
2714         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2715         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2716             SV *sv = NEWSV(85,0);
2717
2718             sv_upgrade(sv, SVt_PVMG);
2719             sv_setsv(sv,PL_linestr);
2720             (void)SvIOK_on(sv);
2721             SvIVX(sv) = 0;
2722             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2723         }
2724         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2725         PL_last_lop = PL_last_uni = Nullch;
2726         if (CopLINE(PL_curcop) == 1) {
2727             while (s < PL_bufend && isSPACE(*s))
2728                 s++;
2729             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2730                 s++;
2731             d = Nullch;
2732             if (!PL_in_eval) {
2733                 if (*s == '#' && *(s+1) == '!')
2734                     d = s + 2;
2735 #ifdef ALTERNATE_SHEBANG
2736                 else {
2737                     static char const as[] = ALTERNATE_SHEBANG;
2738                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2739                         d = s + (sizeof(as) - 1);
2740                 }
2741 #endif /* ALTERNATE_SHEBANG */
2742             }
2743             if (d) {
2744                 char *ipath;
2745                 char *ipathend;
2746
2747                 while (isSPACE(*d))
2748                     d++;
2749                 ipath = d;
2750                 while (*d && !isSPACE(*d))
2751                     d++;
2752                 ipathend = d;
2753
2754 #ifdef ARG_ZERO_IS_SCRIPT
2755                 if (ipathend > ipath) {
2756                     /*
2757                      * HP-UX (at least) sets argv[0] to the script name,
2758                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2759                      * at least, set argv[0] to the basename of the Perl
2760                      * interpreter. So, having found "#!", we'll set it right.
2761                      */
2762                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2763                     assert(SvPOK(x) || SvGMAGICAL(x));
2764                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2765                         sv_setpvn(x, ipath, ipathend - ipath);
2766                         SvSETMAGIC(x);
2767                     }
2768                     else {
2769                         STRLEN blen;
2770                         STRLEN llen;
2771                         char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2772                         char *lstart = SvPV(x,llen);
2773                         if (llen < blen) {
2774                             bstart += blen - llen;
2775                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2776                                 sv_setpvn(x, ipath, ipathend - ipath);
2777                                 SvSETMAGIC(x);
2778                             }
2779                         }
2780                     }
2781                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2782                 }
2783 #endif /* ARG_ZERO_IS_SCRIPT */
2784
2785                 /*
2786                  * Look for options.
2787                  */
2788                 d = instr(s,"perl -");
2789                 if (!d) {
2790                     d = instr(s,"perl");
2791 #if defined(DOSISH)
2792                     /* avoid getting into infinite loops when shebang
2793                      * line contains "Perl" rather than "perl" */
2794                     if (!d) {
2795                         for (d = ipathend-4; d >= ipath; --d) {
2796                             if ((*d == 'p' || *d == 'P')
2797                                 && !ibcmp(d, "perl", 4))
2798                             {
2799                                 break;
2800                             }
2801                         }
2802                         if (d < ipath)
2803                             d = Nullch;
2804                     }
2805 #endif
2806                 }
2807 #ifdef ALTERNATE_SHEBANG
2808                 /*
2809                  * If the ALTERNATE_SHEBANG on this system starts with a
2810                  * character that can be part of a Perl expression, then if
2811                  * we see it but not "perl", we're probably looking at the
2812                  * start of Perl code, not a request to hand off to some
2813                  * other interpreter.  Similarly, if "perl" is there, but
2814                  * not in the first 'word' of the line, we assume the line
2815                  * contains the start of the Perl program.
2816                  */
2817                 if (d && *s != '#') {
2818                     char *c = ipath;
2819                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2820                         c++;
2821                     if (c < d)
2822                         d = Nullch;     /* "perl" not in first word; ignore */
2823                     else
2824                         *s = '#';       /* Don't try to parse shebang line */
2825                 }
2826 #endif /* ALTERNATE_SHEBANG */
2827 #ifndef MACOS_TRADITIONAL
2828                 if (!d &&
2829                     *s == '#' &&
2830                     ipathend > ipath &&
2831                     !PL_minus_c &&
2832                     !instr(s,"indir") &&
2833                     instr(PL_origargv[0],"perl"))
2834                 {
2835                     char **newargv;
2836
2837                     *ipathend = '\0';
2838                     s = ipathend + 1;
2839                     while (s < PL_bufend && isSPACE(*s))
2840                         s++;
2841                     if (s < PL_bufend) {
2842                         Newz(899,newargv,PL_origargc+3,char*);
2843                         newargv[1] = s;
2844                         while (s < PL_bufend && !isSPACE(*s))
2845                             s++;
2846                         *s = '\0';
2847                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2848                     }
2849                     else
2850                         newargv = PL_origargv;
2851                     newargv[0] = ipath;
2852                     PERL_FPU_PRE_EXEC
2853                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2854                     PERL_FPU_POST_EXEC
2855                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2856                 }
2857 #endif
2858                 if (d) {
2859                     U32 oldpdb = PL_perldb;
2860                     bool oldn = PL_minus_n;
2861                     bool oldp = PL_minus_p;
2862
2863                     while (*d && !isSPACE(*d)) d++;
2864                     while (SPACE_OR_TAB(*d)) d++;
2865
2866                     if (*d++ == '-') {
2867                         bool switches_done = PL_doswitches;
2868                         do {
2869                             if (*d == 'M' || *d == 'm') {
2870                                 char *m = d;
2871                                 while (*d && !isSPACE(*d)) d++;
2872                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2873                                       (int)(d - m), m);
2874                             }
2875                             d = moreswitches(d);
2876                         } while (d);
2877                         if (PL_doswitches && !switches_done) {
2878                             int argc = PL_origargc;
2879                             char **argv = PL_origargv;
2880                             do {
2881                                 argc--,argv++;
2882                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2883                             init_argv_symbols(argc,argv);
2884                         }
2885                         if ((PERLDB_LINE && !oldpdb) ||
2886                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2887                               /* if we have already added "LINE: while (<>) {",
2888                                  we must not do it again */
2889                         {
2890                             sv_setpv(PL_linestr, "");
2891                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2892                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2893                             PL_last_lop = PL_last_uni = Nullch;
2894                             PL_preambled = FALSE;
2895                             if (PERLDB_LINE)
2896                                 (void)gv_fetchfile(PL_origfilename);
2897                             goto retry;
2898                         }
2899                         if (PL_doswitches && !switches_done) {
2900                             int argc = PL_origargc;
2901                             char **argv = PL_origargv;
2902                             do {
2903                                 argc--,argv++;
2904                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2905                             init_argv_symbols(argc,argv);
2906                         }
2907                     }
2908                 }
2909             }
2910         }
2911         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2912             PL_bufptr = s;
2913             PL_lex_state = LEX_FORMLINE;
2914             return yylex();
2915         }
2916         goto retry;
2917     case '\r':
2918 #ifdef PERL_STRICT_CR
2919         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2920         Perl_croak(aTHX_
2921       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2922 #endif
2923     case ' ': case '\t': case '\f': case 013:
2924 #ifdef MACOS_TRADITIONAL
2925     case '\312':
2926 #endif
2927         s++;
2928         goto retry;
2929     case '#':
2930     case '\n':
2931         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2932             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2933                 /* handle eval qq[#line 1 "foo"\n ...] */
2934                 CopLINE_dec(PL_curcop);
2935                 incline(s);
2936             }
2937             d = PL_bufend;
2938             while (s < d && *s != '\n')
2939                 s++;
2940             if (s < d)
2941                 s++;
2942             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2943               Perl_croak(aTHX_ "panic: input overflow");
2944             incline(s);
2945             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2946                 PL_bufptr = s;
2947                 PL_lex_state = LEX_FORMLINE;
2948                 return yylex();
2949             }
2950         }
2951         else {
2952             *s = '\0';
2953             PL_bufend = s;
2954         }
2955         goto retry;
2956     case '-':
2957         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2958             I32 ftst = 0;
2959
2960             s++;
2961             PL_bufptr = s;
2962             tmp = *s++;
2963
2964             while (s < PL_bufend && SPACE_OR_TAB(*s))
2965                 s++;
2966
2967             if (strnEQ(s,"=>",2)) {
2968                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2969                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2970                             "### Saw unary minus before =>, forcing word '%s'\n", s);
2971                 } );
2972                 OPERATOR('-');          /* unary minus */
2973             }
2974             PL_last_uni = PL_oldbufptr;
2975             switch (tmp) {
2976             case 'r': ftst = OP_FTEREAD;        break;
2977             case 'w': ftst = OP_FTEWRITE;       break;
2978             case 'x': ftst = OP_FTEEXEC;        break;
2979             case 'o': ftst = OP_FTEOWNED;       break;
2980             case 'R': ftst = OP_FTRREAD;        break;
2981             case 'W': ftst = OP_FTRWRITE;       break;
2982             case 'X': ftst = OP_FTREXEC;        break;
2983             case 'O': ftst = OP_FTROWNED;       break;
2984             case 'e': ftst = OP_FTIS;           break;
2985             case 'z': ftst = OP_FTZERO;         break;
2986             case 's': ftst = OP_FTSIZE;         break;
2987             case 'f': ftst = OP_FTFILE;         break;
2988             case 'd': ftst = OP_FTDIR;          break;
2989             case 'l': ftst = OP_FTLINK;         break;
2990             case 'p': ftst = OP_FTPIPE;         break;
2991             case 'S': ftst = OP_FTSOCK;         break;
2992             case 'u': ftst = OP_FTSUID;         break;
2993             case 'g': ftst = OP_FTSGID;         break;
2994             case 'k': ftst = OP_FTSVTX;         break;
2995             case 'b': ftst = OP_FTBLK;          break;
2996             case 'c': ftst = OP_FTCHR;          break;
2997             case 't': ftst = OP_FTTTY;          break;
2998             case 'T': ftst = OP_FTTEXT;         break;
2999             case 'B': ftst = OP_FTBINARY;       break;
3000             case 'M': case 'A': case 'C':
3001                 gv_fetchpv("\024",TRUE, SVt_PV);
3002                 switch (tmp) {
3003                 case 'M': ftst = OP_FTMTIME;    break;
3004                 case 'A': ftst = OP_FTATIME;    break;
3005                 case 'C': ftst = OP_FTCTIME;    break;
3006                 default:                        break;
3007                 }
3008                 break;
3009             default:
3010                 break;
3011             }
3012             if (ftst) {
3013                 PL_last_lop_op = (OPCODE)ftst;
3014                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3015                         "### Saw file test %c\n", (int)ftst);
3016                 } );
3017                 FTST(ftst);
3018             }
3019             else {
3020                 /* Assume it was a minus followed by a one-letter named
3021                  * subroutine call (or a -bareword), then. */
3022                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
3023                         "### '-%c' looked like a file test but was not\n",
3024                         (int) tmp);
3025                 } );
3026                 s = --PL_bufptr;
3027             }
3028         }
3029         tmp = *s++;
3030         if (*s == tmp) {
3031             s++;
3032             if (PL_expect == XOPERATOR)
3033                 TERM(POSTDEC);
3034             else
3035                 OPERATOR(PREDEC);
3036         }
3037         else if (*s == '>') {
3038             s++;
3039             s = skipspace(s);
3040             if (isIDFIRST_lazy_if(s,UTF)) {
3041                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
3042                 TOKEN(ARROW);
3043             }
3044             else if (*s == '$')
3045                 OPERATOR(ARROW);
3046             else
3047                 TERM(ARROW);
3048         }
3049         if (PL_expect == XOPERATOR)
3050             Aop(OP_SUBTRACT);
3051         else {
3052             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3053                 check_uni();
3054             OPERATOR('-');              /* unary minus */
3055         }
3056
3057     case '+':
3058         tmp = *s++;
3059         if (*s == tmp) {
3060             s++;
3061             if (PL_expect == XOPERATOR)
3062                 TERM(POSTINC);
3063             else
3064                 OPERATOR(PREINC);
3065         }
3066         if (PL_expect == XOPERATOR)
3067             Aop(OP_ADD);
3068         else {
3069             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
3070                 check_uni();
3071             OPERATOR('+');
3072         }
3073
3074     case '*':
3075         if (PL_expect != XOPERATOR) {
3076             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3077             PL_expect = XOPERATOR;
3078             force_ident(PL_tokenbuf, '*');
3079             if (!*PL_tokenbuf)
3080                 PREREF('*');
3081             TERM('*');
3082         }
3083         s++;
3084         if (*s == '*') {
3085             s++;
3086             PWop(OP_POW);
3087         }
3088         Mop(OP_MULTIPLY);
3089
3090     case '%':
3091         if (PL_expect == XOPERATOR) {
3092             ++s;
3093             Mop(OP_MODULO);
3094         }
3095         PL_tokenbuf[0] = '%';
3096         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
3097         if (!PL_tokenbuf[1]) {
3098             PREREF('%');
3099         }
3100         PL_pending_ident = '%';
3101         TERM('%');
3102
3103     case '^':
3104         s++;
3105         BOop(OP_BIT_XOR);
3106     case '[':
3107         PL_lex_brackets++;
3108         /* FALL THROUGH */
3109     case '~':
3110     case ',':
3111         tmp = *s++;
3112         OPERATOR(tmp);
3113     case ':':
3114         if (s[1] == ':') {
3115             len = 0;
3116             goto just_a_word;
3117         }
3118         s++;
3119         switch (PL_expect) {
3120             OP *attrs;
3121         case XOPERATOR:
3122             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
3123                 break;
3124             PL_bufptr = s;      /* update in case we back off */
3125             goto grabattrs;
3126         case XATTRBLOCK:
3127             PL_expect = XBLOCK;
3128             goto grabattrs;
3129         case XATTRTERM:
3130             PL_expect = XTERMBLOCK;
3131          grabattrs:
3132             s = skipspace(s);
3133             attrs = Nullop;
3134             while (isIDFIRST_lazy_if(s,UTF)) {
3135                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3136                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3137                     if (tmp < 0) tmp = -tmp;
3138                     switch (tmp) {
3139                     case KEY_or:
3140                     case KEY_and:
3141                     case KEY_err:
3142                     case KEY_for:
3143                     case KEY_unless:
3144                     case KEY_if:
3145                     case KEY_while:
3146                     case KEY_until:
3147                         goto got_attrs;
3148                     default:
3149                         break;
3150                     }
3151                 }
3152                 if (*d == '(') {
3153                     d = scan_str(d,TRUE,TRUE);
3154                     if (!d) {
3155                         /* MUST advance bufptr here to avoid bogus
3156                            "at end of line" context messages from yyerror().
3157                          */
3158                         PL_bufptr = s + len;
3159                         yyerror("Unterminated attribute parameter in attribute list");
3160                         if (attrs)
3161                             op_free(attrs);
3162                         return REPORT(0);       /* EOF indicator */
3163                     }
3164                 }
3165                 if (PL_lex_stuff) {
3166                     SV *sv = newSVpvn(s, len);
3167                     sv_catsv(sv, PL_lex_stuff);
3168                     attrs = append_elem(OP_LIST, attrs,
3169                                         newSVOP(OP_CONST, 0, sv));
3170                     SvREFCNT_dec(PL_lex_stuff);
3171                     PL_lex_stuff = Nullsv;
3172                 }
3173                 else {
3174                     if (len == 6 && strnEQ(s, "unique", len)) {
3175                         if (PL_in_my == KEY_our)
3176 #ifdef USE_ITHREADS
3177                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3178 #else
3179                             ; /* skip to avoid loading attributes.pm */
3180 #endif
3181                         else
3182                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
3183                     }
3184
3185                     /* NOTE: any CV attrs applied here need to be part of
3186                        the CVf_BUILTIN_ATTRS define in cv.h! */
3187                     else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3188                         CvLVALUE_on(PL_compcv);
3189                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3190                         CvLOCKED_on(PL_compcv);
3191                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3192                         CvMETHOD_on(PL_compcv);
3193                     else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3194                         CvASSERTION_on(PL_compcv);
3195                     /* After we've set the flags, it could be argued that
3196                        we don't need to do the attributes.pm-based setting
3197                        process, and shouldn't bother appending recognized
3198                        flags.  To experiment with that, uncomment the
3199                        following "else".  (Note that's already been
3200                        uncommented.  That keeps the above-applied built-in
3201                        attributes from being intercepted (and possibly
3202                        rejected) by a package's attribute routines, but is
3203                        justified by the performance win for the common case
3204                        of applying only built-in attributes.) */
3205                     else
3206                         attrs = append_elem(OP_LIST, attrs,
3207                                             newSVOP(OP_CONST, 0,
3208                                                     newSVpvn(s, len)));
3209                 }
3210                 s = skipspace(d);
3211                 if (*s == ':' && s[1] != ':')
3212                     s = skipspace(s+1);
3213                 else if (s == d)
3214                     break;      /* require real whitespace or :'s */
3215             }
3216             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3217             if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3218                 char q = ((*s == '\'') ? '"' : '\'');
3219                 /* If here for an expression, and parsed no attrs, back off. */
3220                 if (tmp == '=' && !attrs) {
3221                     s = PL_bufptr;
3222                     break;
3223                 }
3224                 /* MUST advance bufptr here to avoid bogus "at end of line"
3225                    context messages from yyerror().
3226                  */
3227                 PL_bufptr = s;
3228                 if (!*s)
3229                     yyerror("Unterminated attribute list");
3230                 else
3231                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3232                                       q, *s, q));
3233                 if (attrs)
3234                     op_free(attrs);
3235                 OPERATOR(':');
3236             }
3237         got_attrs:
3238             if (attrs) {
3239                 PL_nextval[PL_nexttoke].opval = attrs;
3240                 force_next(THING);
3241             }
3242             TOKEN(COLONATTR);
3243         }
3244         OPERATOR(':');
3245     case '(':
3246         s++;
3247         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3248             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3249         else
3250             PL_expect = XTERM;
3251         s = skipspace(s);
3252         TOKEN('(');
3253     case ';':
3254         CLINE;
3255         tmp = *s++;
3256         OPERATOR(tmp);
3257     case ')':
3258         tmp = *s++;
3259         s = skipspace(s);
3260         if (*s == '{')
3261             PREBLOCK(tmp);
3262         TERM(tmp);
3263     case ']':
3264         s++;
3265         if (PL_lex_brackets <= 0)
3266             yyerror("Unmatched right square bracket");
3267         else
3268             --PL_lex_brackets;
3269         if (PL_lex_state == LEX_INTERPNORMAL) {
3270             if (PL_lex_brackets == 0) {
3271                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3272                     PL_lex_state = LEX_INTERPEND;
3273             }
3274         }
3275         TERM(']');
3276     case '{':
3277       leftbracket:
3278         s++;
3279         if (PL_lex_brackets > 100) {
3280             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3281         }
3282         switch (PL_expect) {
3283         case XTERM:
3284             if (PL_lex_formbrack) {
3285                 s--;
3286                 PRETERMBLOCK(DO);
3287             }
3288             if (PL_oldoldbufptr == PL_last_lop)
3289                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3290             else
3291                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3292             OPERATOR(HASHBRACK);
3293         case XOPERATOR:
3294             while (s < PL_bufend && SPACE_OR_TAB(*s))
3295                 s++;
3296             d = s;
3297             PL_tokenbuf[0] = '\0';
3298             if (d < PL_bufend && *d == '-') {
3299                 PL_tokenbuf[0] = '-';
3300                 d++;
3301                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3302                     d++;
3303             }
3304             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3305                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3306                               FALSE, &len);
3307                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3308                     d++;
3309                 if (*d == '}') {
3310                     char minus = (PL_tokenbuf[0] == '-');
3311                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3312                     if (minus)
3313                         force_next('-');
3314                 }
3315             }
3316             /* FALL THROUGH */
3317         case XATTRBLOCK:
3318         case XBLOCK:
3319             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3320             PL_expect = XSTATE;
3321             break;
3322         case XATTRTERM:
3323         case XTERMBLOCK:
3324             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3325             PL_expect = XSTATE;
3326             break;
3327         default: {
3328                 char *t;
3329                 if (PL_oldoldbufptr == PL_last_lop)
3330                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3331                 else
3332                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3333                 s = skipspace(s);
3334                 if (*s == '}') {
3335                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3336                         PL_expect = XTERM;
3337                         /* This hack is to get the ${} in the message. */
3338                         PL_bufptr = s+1;
3339                         yyerror("syntax error");
3340                         break;
3341                     }
3342                     OPERATOR(HASHBRACK);
3343                 }
3344                 /* This hack serves to disambiguate a pair of curlies
3345                  * as being a block or an anon hash.  Normally, expectation
3346                  * determines that, but in cases where we're not in a
3347                  * position to expect anything in particular (like inside
3348                  * eval"") we have to resolve the ambiguity.  This code
3349                  * covers the case where the first term in the curlies is a
3350                  * quoted string.  Most other cases need to be explicitly
3351                  * disambiguated by prepending a `+' before the opening
3352                  * curly in order to force resolution as an anon hash.
3353                  *
3354                  * XXX should probably propagate the outer expectation
3355                  * into eval"" to rely less on this hack, but that could
3356                  * potentially break current behavior of eval"".
3357                  * GSAR 97-07-21
3358                  */
3359                 t = s;
3360                 if (*s == '\'' || *s == '"' || *s == '`') {
3361                     /* common case: get past first string, handling escapes */
3362                     for (t++; t < PL_bufend && *t != *s;)
3363                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3364                             t++;
3365                     t++;
3366                 }
3367                 else if (*s == 'q') {
3368                     if (++t < PL_bufend
3369                         && (!isALNUM(*t)
3370                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3371                                 && !isALNUM(*t))))
3372                     {
3373                         /* skip q//-like construct */
3374                         char *tmps;
3375                         char open, close, term;
3376                         I32 brackets = 1;
3377
3378                         while (t < PL_bufend && isSPACE(*t))
3379                             t++;
3380                         /* check for q => */
3381                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3382                             OPERATOR(HASHBRACK);
3383                         }
3384                         term = *t;
3385                         open = term;
3386                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3387                             term = tmps[5];
3388                         close = term;
3389                         if (open == close)
3390                             for (t++; t < PL_bufend; t++) {
3391                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3392                                     t++;
3393                                 else if (*t == open)
3394                                     break;
3395                             }
3396                         else {
3397                             for (t++; t < PL_bufend; t++) {
3398                                 if (*t == '\\' && t+1 < PL_bufend)
3399                                     t++;
3400                                 else if (*t == close && --brackets <= 0)
3401                                     break;
3402                                 else if (*t == open)
3403                                     brackets++;
3404                             }
3405                         }
3406                         t++;
3407                     }
3408                     else
3409                         /* skip plain q word */
3410                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3411                              t += UTF8SKIP(t);
3412                 }
3413                 else if (isALNUM_lazy_if(t,UTF)) {
3414                     t += UTF8SKIP(t);
3415                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3416                          t += UTF8SKIP(t);
3417                 }
3418                 while (t < PL_bufend && isSPACE(*t))
3419                     t++;
3420                 /* if comma follows first term, call it an anon hash */
3421                 /* XXX it could be a comma expression with loop modifiers */
3422                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3423                                    || (*t == '=' && t[1] == '>')))
3424                     OPERATOR(HASHBRACK);
3425                 if (PL_expect == XREF)
3426                     PL_expect = XTERM;
3427                 else {
3428                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3429                     PL_expect = XSTATE;
3430                 }
3431             }
3432             break;
3433         }
3434         yylval.ival = CopLINE(PL_curcop);
3435         if (isSPACE(*s) || *s == '#')
3436             PL_copline = NOLINE;   /* invalidate current command line number */
3437         TOKEN('{');
3438     case '}':
3439       rightbracket:
3440         s++;
3441         if (PL_lex_brackets <= 0)
3442             yyerror("Unmatched right curly bracket");
3443         else
3444             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3445         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3446             PL_lex_formbrack = 0;
3447         if (PL_lex_state == LEX_INTERPNORMAL) {
3448             if (PL_lex_brackets == 0) {
3449                 if (PL_expect & XFAKEBRACK) {
3450                     PL_expect &= XENUMMASK;
3451                     PL_lex_state = LEX_INTERPEND;
3452                     PL_bufptr = s;
3453                     return yylex();     /* ignore fake brackets */
3454                 }
3455                 if (*s == '-' && s[1] == '>')
3456                     PL_lex_state = LEX_INTERPENDMAYBE;
3457                 else if (*s != '[' && *s != '{')
3458                     PL_lex_state = LEX_INTERPEND;
3459             }
3460         }
3461         if (PL_expect & XFAKEBRACK) {
3462             PL_expect &= XENUMMASK;
3463             PL_bufptr = s;
3464             return yylex();             /* ignore fake brackets */
3465         }
3466         force_next('}');
3467         TOKEN(';');
3468     case '&':
3469         s++;
3470         tmp = *s++;
3471         if (tmp == '&')
3472             AOPERATOR(ANDAND);
3473         s--;
3474         if (PL_expect == XOPERATOR) {
3475             if (ckWARN(WARN_SEMICOLON)
3476                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3477             {
3478                 CopLINE_dec(PL_curcop);
3479                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3480                 CopLINE_inc(PL_curcop);
3481             }
3482             BAop(OP_BIT_AND);
3483         }
3484
3485         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3486         if (*PL_tokenbuf) {
3487             PL_expect = XOPERATOR;
3488             force_ident(PL_tokenbuf, '&');
3489         }
3490         else
3491             PREREF('&');
3492         yylval.ival = (OPpENTERSUB_AMPER<<8);
3493         TERM('&');
3494
3495     case '|':
3496         s++;
3497         tmp = *s++;
3498         if (tmp == '|')
3499             AOPERATOR(OROR);
3500         s--;
3501         BOop(OP_BIT_OR);
3502     case '=':
3503         s++;
3504         tmp = *s++;
3505         if (tmp == '=')
3506             Eop(OP_EQ);
3507         if (tmp == '>')
3508             OPERATOR(',');
3509         if (tmp == '~')
3510             PMop(OP_MATCH);
3511         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3512             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3513         s--;
3514         if (PL_expect == XSTATE && isALPHA(tmp) &&
3515                 (s == PL_linestart+1 || s[-2] == '\n') )
3516         {
3517             if (PL_in_eval && !PL_rsfp) {
3518                 d = PL_bufend;
3519                 while (s < d) {
3520                     if (*s++ == '\n') {
3521                         incline(s);
3522                         if (strnEQ(s,"=cut",4)) {
3523                             s = strchr(s,'\n');
3524                             if (s)
3525                                 s++;
3526                             else
3527                                 s = d;
3528                             incline(s);
3529                             goto retry;
3530                         }
3531                     }
3532                 }
3533                 goto retry;
3534             }
3535             s = PL_bufend;
3536             PL_doextract = TRUE;
3537             goto retry;
3538         }
3539         if (PL_lex_brackets < PL_lex_formbrack) {
3540             char *t;
3541 #ifdef PERL_STRICT_CR
3542             for (t = s; SPACE_OR_TAB(*t); t++) ;
3543 #else
3544             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3545 #endif
3546             if (*t == '\n' || *t == '#') {
3547                 s--;
3548                 PL_expect = XBLOCK;
3549                 goto leftbracket;
3550             }
3551         }
3552         yylval.ival = 0;
3553         OPERATOR(ASSIGNOP);
3554     case '!':
3555         s++;
3556         tmp = *s++;
3557         if (tmp == '=') {
3558             /* was this !=~ where !~ was meant?
3559              * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
3560
3561             if (*s == '~' && ckWARN(WARN_SYNTAX)) {
3562                 char *t = s+1;
3563
3564                 while (t < PL_bufend && isSPACE(*t))
3565                     ++t;
3566
3567                 if (*t == '/' || *t == '?' ||
3568                     ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) ||
3569                     (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
3570                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3571                                 "!=~ should be !~");
3572             }
3573             Eop(OP_NE);
3574         }
3575         if (tmp == '~')
3576             PMop(OP_NOT);
3577         s--;
3578         OPERATOR('!');
3579     case '<':
3580         if (PL_expect != XOPERATOR) {
3581             if (s[1] != '<' && !strchr(s,'>'))
3582                 check_uni();
3583             if (s[1] == '<')
3584                 s = scan_heredoc(s);
3585             else
3586                 s = scan_inputsymbol(s);
3587             TERM(sublex_start());
3588         }
3589         s++;
3590         tmp = *s++;
3591         if (tmp == '<')
3592             SHop(OP_LEFT_SHIFT);
3593         if (tmp == '=') {
3594             tmp = *s++;
3595             if (tmp == '>')
3596                 Eop(OP_NCMP);
3597             s--;
3598             Rop(OP_LE);
3599         }
3600         s--;
3601         Rop(OP_LT);
3602     case '>':
3603         s++;
3604         tmp = *s++;
3605         if (tmp == '>')
3606             SHop(OP_RIGHT_SHIFT);
3607         if (tmp == '=')
3608             Rop(OP_GE);
3609         s--;
3610         Rop(OP_GT);
3611
3612     case '$':
3613         CLINE;
3614
3615         if (PL_expect == XOPERATOR) {
3616             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3617                 PL_expect = XTERM;
3618                 depcom();
3619                 return REPORT(','); /* grandfather non-comma-format format */
3620             }
3621         }
3622
3623         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3624             PL_tokenbuf[0] = '@';
3625             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3626                            sizeof PL_tokenbuf - 1, FALSE);
3627             if (PL_expect == XOPERATOR)
3628                 no_op("Array length", s);
3629             if (!PL_tokenbuf[1])
3630                 PREREF(DOLSHARP);
3631             PL_expect = XOPERATOR;
3632             PL_pending_ident = '#';
3633             TOKEN(DOLSHARP);
3634         }
3635
3636         PL_tokenbuf[0] = '$';
3637         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3638                        sizeof PL_tokenbuf - 1, FALSE);
3639         if (PL_expect == XOPERATOR)
3640             no_op("Scalar", s);
3641         if (!PL_tokenbuf[1]) {
3642             if (s == PL_bufend)
3643                 yyerror("Final $ should be \\$ or $name");
3644             PREREF('$');
3645         }
3646
3647         /* This kludge not intended to be bulletproof. */
3648         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3649             yylval.opval = newSVOP(OP_CONST, 0,
3650                                    newSViv(PL_compiling.cop_arybase));
3651             yylval.opval->op_private = OPpCONST_ARYBASE;
3652             TERM(THING);
3653         }
3654
3655         d = s;
3656         tmp = (I32)*s;
3657         if (PL_lex_state == LEX_NORMAL)
3658             s = skipspace(s);
3659
3660         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3661             char *t;
3662             if (*s == '[') {
3663                 PL_tokenbuf[0] = '@';
3664                 if (ckWARN(WARN_SYNTAX)) {
3665                     for(t = s + 1;
3666                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3667                         t++) ;
3668                     if (*t++ == ',') {
3669                         PL_bufptr = skipspace(PL_bufptr);
3670                         while (t < PL_bufend && *t != ']')
3671                             t++;
3672                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3673                                 "Multidimensional syntax %.*s not supported",
3674                                 (t - PL_bufptr) + 1, PL_bufptr);
3675                     }
3676                 }
3677             }
3678             else if (*s == '{') {
3679                 PL_tokenbuf[0] = '%';
3680                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3681                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3682                 {
3683                     char tmpbuf[sizeof PL_tokenbuf];
3684                     STRLEN len;
3685                     for (t++; isSPACE(*t); t++) ;
3686                     if (isIDFIRST_lazy_if(t,UTF)) {
3687                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3688                         for (; isSPACE(*t); t++) ;
3689                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3690                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3691                                 "You need to quote \"%s\"", tmpbuf);
3692                     }
3693                 }
3694             }
3695         }
3696
3697         PL_expect = XOPERATOR;
3698         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3699             bool islop = (PL_last_lop == PL_oldoldbufptr);
3700             if (!islop || PL_last_lop_op == OP_GREPSTART)
3701                 PL_expect = XOPERATOR;
3702             else if (strchr("$@\"'`q", *s))
3703                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3704             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3705                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3706             else if (isIDFIRST_lazy_if(s,UTF)) {
3707                 char tmpbuf[sizeof PL_tokenbuf];
3708                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3709                 if ((tmp = keyword(tmpbuf, len))) {
3710                     /* binary operators exclude handle interpretations */
3711                     switch (tmp) {
3712                     case -KEY_x:
3713                     case -KEY_eq:
3714                     case -KEY_ne:
3715                     case -KEY_gt:
3716                     case -KEY_lt:
3717                     case -KEY_ge:
3718                     case -KEY_le:
3719                     case -KEY_cmp:
3720                         break;
3721                     default:
3722                         PL_expect = XTERM;      /* e.g. print $fh length() */
3723                         break;
3724                     }
3725                 }
3726                 else {
3727                     PL_expect = XTERM;          /* e.g. print $fh subr() */
3728                 }
3729             }
3730             else if (isDIGIT(*s))
3731                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3732             else if (*s == '.' && isDIGIT(s[1]))
3733                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3734             else if ((*s == '?' || *s == '-' || *s == '+')
3735                      && !isSPACE(s[1]) && s[1] != '=')
3736                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3737             else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3738                 PL_expect = XTERM;              /* e.g. print $fh /.../
3739                                                  XXX except DORDOR operator */
3740             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3741                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3742         }
3743         PL_pending_ident = '$';
3744         TOKEN('$');
3745
3746     case '@':
3747         if (PL_expect == XOPERATOR)
3748             no_op("Array", s);
3749         PL_tokenbuf[0] = '@';
3750         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3751         if (!PL_tokenbuf[1]) {
3752             PREREF('@');
3753         }
3754         if (PL_lex_state == LEX_NORMAL)
3755             s = skipspace(s);
3756         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3757             if (*s == '{')
3758                 PL_tokenbuf[0] = '%';
3759
3760             /* Warn about @ where they meant $. */
3761             if (ckWARN(WARN_SYNTAX)) {
3762                 if (*s == '[' || *s == '{') {
3763                     char *t = s + 1;
3764                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3765                         t++;
3766                     if (*t == '}' || *t == ']') {
3767                         t++;
3768                         PL_bufptr = skipspace(PL_bufptr);
3769                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3770                             "Scalar value %.*s better written as $%.*s",
3771                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3772                     }
3773                 }
3774             }
3775         }
3776         PL_pending_ident = '@';
3777         TERM('@');
3778
3779      case '/':                  /* may be division, defined-or, or pattern */
3780         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3781             s += 2;
3782             AOPERATOR(DORDOR);
3783         }
3784      case '?':                  /* may either be conditional or pattern */
3785          if(PL_expect == XOPERATOR) {
3786              tmp = *s++;
3787              if(tmp == '?') {
3788                   OPERATOR('?');
3789              }
3790              else {
3791                  tmp = *s++;
3792                  if(tmp == '/') {
3793                      /* A // operator. */
3794                     AOPERATOR(DORDOR);
3795                  }
3796                  else {
3797                      s--;
3798                      Mop(OP_DIVIDE);
3799                  }
3800              }
3801          }
3802          else {
3803              /* Disable warning on "study /blah/" */
3804              if (PL_oldoldbufptr == PL_last_uni
3805               && (*PL_last_uni != 's' || s - PL_last_uni < 5
3806                   || memNE(PL_last_uni, "study", 5)
3807                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
3808               ))
3809                  check_uni();
3810              s = scan_pat(s,OP_MATCH);
3811              TERM(sublex_start());
3812          }
3813
3814     case '.':
3815         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3816 #ifdef PERL_STRICT_CR
3817             && s[1] == '\n'
3818 #else
3819             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3820 #endif
3821             && (s == PL_linestart || s[-1] == '\n') )
3822         {
3823             PL_lex_formbrack = 0;
3824             PL_expect = XSTATE;
3825             goto rightbracket;
3826         }
3827         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3828             tmp = *s++;
3829             if (*s == tmp) {
3830                 s++;
3831                 if (*s == tmp) {
3832                     s++;
3833                     yylval.ival = OPf_SPECIAL;
3834                 }
3835                 else
3836                     yylval.ival = 0;
3837                 OPERATOR(DOTDOT);
3838             }
3839             if (PL_expect != XOPERATOR)
3840                 check_uni();
3841             Aop(OP_CONCAT);
3842         }
3843         /* FALL THROUGH */
3844     case '0': case '1': case '2': case '3': case '4':
3845     case '5': case '6': case '7': case '8': case '9':
3846         s = scan_num(s, &yylval);
3847         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3848                     "### Saw number in '%s'\n", s);
3849         } );
3850         if (PL_expect == XOPERATOR)
3851             no_op("Number",s);
3852         TERM(THING);
3853
3854     case '\'':
3855         s = scan_str(s,FALSE,FALSE);
3856         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3857                     "### Saw string before '%s'\n", s);
3858         } );
3859         if (PL_expect == XOPERATOR) {
3860             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3861                 PL_expect = XTERM;
3862                 depcom();
3863                 return REPORT(','); /* grandfather non-comma-format format */
3864             }
3865             else
3866                 no_op("String",s);
3867         }
3868         if (!s)
3869             missingterm((char*)0);
3870         yylval.ival = OP_CONST;
3871         TERM(sublex_start());
3872
3873     case '"':
3874         s = scan_str(s,FALSE,FALSE);
3875         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3876                     "### Saw string before '%s'\n", s);
3877         } );
3878         if (PL_expect == XOPERATOR) {
3879             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3880                 PL_expect = XTERM;
3881                 depcom();
3882                 return REPORT(','); /* grandfather non-comma-format format */
3883             }
3884             else
3885                 no_op("String",s);
3886         }
3887         if (!s)
3888             missingterm((char*)0);
3889         yylval.ival = OP_CONST;
3890         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3891             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3892                 yylval.ival = OP_STRINGIFY;
3893                 break;
3894             }
3895         }
3896         TERM(sublex_start());
3897
3898     case '`':
3899         s = scan_str(s,FALSE,FALSE);
3900         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3901                     "### Saw backtick string before '%s'\n", s);
3902         } );
3903         if (PL_expect == XOPERATOR)
3904             no_op("Backticks",s);
3905         if (!s)
3906             missingterm((char*)0);
3907         yylval.ival = OP_BACKTICK;
3908         set_csh();
3909         TERM(sublex_start());
3910
3911     case '\\':
3912         s++;
3913         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3914             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3915                         *s, *s);
3916         if (PL_expect == XOPERATOR)
3917             no_op("Backslash",s);
3918         OPERATOR(REFGEN);
3919
3920     case 'v':
3921         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3922             char *start = s;
3923             start++;
3924             start++;
3925             while (isDIGIT(*start) || *start == '_')
3926                 start++;
3927             if (*start == '.' && isDIGIT(start[1])) {
3928                 s = scan_num(s, &yylval);
3929                 TERM(THING);
3930             }
3931             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3932             else if (!isALPHA(*start) && (PL_expect == XTERM
3933                         || PL_expect == XREF || PL_expect == XSTATE
3934                         || PL_expect == XTERMORDORDOR)) {
3935                 char c = *start;
3936                 GV *gv;
3937                 *start = '\0';
3938                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3939                 *start = c;
3940                 if (!gv) {
3941                     s = scan_num(s, &yylval);
3942                     TERM(THING);
3943                 }
3944             }
3945         }
3946         goto keylookup;
3947     case 'x':
3948         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3949             s++;
3950             Mop(OP_REPEAT);
3951         }
3952         goto keylookup;
3953
3954     case '_':
3955     case 'a': case 'A':
3956     case 'b': case 'B':
3957     case 'c': case 'C':
3958     case 'd': case 'D':
3959     case 'e': case 'E':
3960     case 'f': case 'F':
3961     case 'g': case 'G':
3962     case 'h': case 'H':
3963     case 'i': case 'I':
3964     case 'j': case 'J':
3965     case 'k': case 'K':
3966     case 'l': case 'L':
3967     case 'm': case 'M':
3968     case 'n': case 'N':
3969     case 'o': case 'O':
3970     case 'p': case 'P':
3971     case 'q': case 'Q':
3972     case 'r': case 'R':
3973     case 's': case 'S':
3974     case 't': case 'T':
3975     case 'u': case 'U':
3976               case 'V':
3977     case 'w': case 'W':
3978               case 'X':
3979     case 'y': case 'Y':
3980     case 'z': case 'Z':
3981
3982       keylookup: {
3983         orig_keyword = 0;
3984         gv = Nullgv;
3985         gvp = 0;
3986
3987         PL_bufptr = s;
3988         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3989
3990         /* Some keywords can be followed by any delimiter, including ':' */
3991         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3992                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3993                              (PL_tokenbuf[0] == 'q' &&
3994                               strchr("qwxr", PL_tokenbuf[1])))));
3995
3996         /* x::* is just a word, unless x is "CORE" */
3997         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3998             goto just_a_word;
3999
4000         d = s;
4001         while (d < PL_bufend && isSPACE(*d))
4002                 d++;    /* no comments skipped here, or s### is misparsed */
4003
4004         /* Is this a label? */
4005         if (!tmp && PL_expect == XSTATE
4006               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
4007             s = d + 1;
4008             yylval.pval = savepv(PL_tokenbuf);
4009             CLINE;
4010             TOKEN(LABEL);
4011         }
4012
4013         /* Check for keywords */
4014         tmp = keyword(PL_tokenbuf, len);
4015
4016         /* Is this a word before a => operator? */
4017         if (*d == '=' && d[1] == '>') {
4018             CLINE;
4019             yylval.opval
4020                 = (OP*)newSVOP(OP_CONST, 0,
4021                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
4022             yylval.opval->op_private = OPpCONST_BARE;
4023             TERM(WORD);
4024         }
4025
4026         if (tmp < 0) {                  /* second-class keyword? */
4027             GV *ogv = Nullgv;   /* override (winner) */
4028             GV *hgv = Nullgv;   /* hidden (loser) */
4029             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
4030                 CV *cv;
4031                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
4032                     (cv = GvCVu(gv)))
4033                 {
4034                     if (GvIMPORTED_CV(gv))
4035                         ogv = gv;
4036                     else if (! CvMETHOD(cv))
4037                         hgv = gv;
4038                 }
4039                 if (!ogv &&
4040                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
4041                     (gv = *gvp) != (GV*)&PL_sv_undef &&
4042                     GvCVu(gv) && GvIMPORTED_CV(gv))
4043                 {
4044                     ogv = gv;
4045                 }
4046             }
4047             if (ogv) {
4048                 orig_keyword = tmp;
4049                 tmp = 0;                /* overridden by import or by GLOBAL */
4050             }
4051             else if (gv && !gvp
4052                      && -tmp==KEY_lock  /* XXX generalizable kludge */
4053                      && GvCVu(gv)
4054                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
4055             {
4056                 tmp = 0;                /* any sub overrides "weak" keyword */
4057             }
4058             else if (gv && !gvp
4059                     && tmp == -KEY_err
4060                     && GvCVu(gv)
4061                     && PL_expect != XOPERATOR
4062                     && PL_expect != XTERMORDORDOR)
4063             {
4064                 /* any sub overrides the "err" keyword, except when really an
4065                  * operator is expected */
4066                 tmp = 0;
4067             }
4068             else {                      /* no override */
4069                 tmp = -tmp;
4070                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
4071                     Perl_warner(aTHX_ packWARN(WARN_MISC),
4072                             "dump() better written as CORE::dump()");
4073                 }
4074                 gv = Nullgv;
4075                 gvp = 0;
4076                 if (ckWARN(WARN_AMBIGUOUS) && hgv
4077                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
4078                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4079                         "Ambiguous call resolved as CORE::%s(), %s",
4080                          GvENAME(hgv), "qualify as such or use &");
4081             }
4082         }
4083
4084       reserved_word:
4085         switch (tmp) {
4086
4087         default:                        /* not a keyword */
4088           just_a_word: {
4089                 SV *sv;
4090                 int pkgname = 0;
4091                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
4092
4093                 /* Get the rest if it looks like a package qualifier */
4094
4095                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
4096                     STRLEN morelen;
4097                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
4098                                   TRUE, &morelen);
4099                     if (!morelen)
4100                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
4101                                 *s == '\'' ? "'" : "::");
4102                     len += morelen;
4103                     pkgname = 1;
4104                 }
4105
4106                 if (PL_expect == XOPERATOR) {
4107                     if (PL_bufptr == PL_linestart) {
4108                         CopLINE_dec(PL_curcop);
4109                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4110                         CopLINE_inc(PL_curcop);
4111                     }
4112                     else
4113                         no_op("Bareword",s);
4114                 }
4115
4116                 /* Look for a subroutine with this name in current package,
4117                    unless name is "Foo::", in which case Foo is a bearword
4118                    (and a package name). */
4119
4120                 if (len > 2 &&
4121                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
4122                 {
4123                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
4124                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
4125                             "Bareword \"%s\" refers to nonexistent package",
4126                              PL_tokenbuf);
4127                     len -= 2;
4128                     PL_tokenbuf[len] = '\0';
4129                     gv = Nullgv;
4130                     gvp = 0;
4131                 }
4132                 else {
4133                     len = 0;
4134                     if (!gv)
4135                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
4136                 }
4137
4138                 /* if we saw a global override before, get the right name */
4139
4140                 if (gvp) {
4141                     sv = newSVpvn("CORE::GLOBAL::",14);
4142                     sv_catpv(sv,PL_tokenbuf);
4143                 }
4144                 else {
4145                     /* If len is 0, newSVpv does strlen(), which is correct.
4146                        If len is non-zero, then it will be the true length,
4147                        and so the scalar will be created correctly.  */
4148                     sv = newSVpv(PL_tokenbuf,len);
4149                 }
4150
4151                 /* Presume this is going to be a bareword of some sort. */
4152
4153                 CLINE;
4154                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
4155                 yylval.opval->op_private = OPpCONST_BARE;
4156                 /* UTF-8 package name? */
4157                 if (UTF && !IN_BYTES &&
4158                     is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
4159                     SvUTF8_on(sv);
4160
4161                 /* And if "Foo::", then that's what it certainly is. */
4162
4163                 if (len)
4164                     goto safe_bareword;
4165
4166                 /* See if it's the indirect object for a list operator. */
4167
4168                 if (PL_oldoldbufptr &&
4169                     PL_oldoldbufptr < PL_bufptr &&
4170                     (PL_oldoldbufptr == PL_last_lop
4171                      || PL_oldoldbufptr == PL_last_uni) &&
4172                     /* NO SKIPSPACE BEFORE HERE! */
4173                     (PL_expect == XREF ||
4174                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4175                 {
4176                     bool immediate_paren = *s == '(';
4177
4178                     /* (Now we can afford to cross potential line boundary.) */
4179                     s = skipspace(s);
4180
4181                     /* Two barewords in a row may indicate method call. */
4182
4183                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4184                         return REPORT(tmp);
4185
4186                     /* If not a declared subroutine, it's an indirect object. */
4187                     /* (But it's an indir obj regardless for sort.) */
4188
4189                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4190                          ((!gv || !GvCVu(gv)) &&
4191                         (PL_last_lop_op != OP_MAPSTART &&
4192                          PL_last_lop_op != OP_GREPSTART))))
4193                     {
4194                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4195                         goto bareword;
4196                     }
4197                 }
4198
4199                 PL_expect = XOPERATOR;
4200                 s = skipspace(s);
4201
4202                 /* Is this a word before a => operator? */
4203                 if (*s == '=' && s[1] == '>' && !pkgname) {
4204                     CLINE;
4205                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4206                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4207                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4208                     TERM(WORD);
4209                 }
4210
4211                 /* If followed by a paren, it's certainly a subroutine. */
4212                 if (*s == '(') {
4213                     CLINE;
4214                     if (gv && GvCVu(gv)) {
4215                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4216                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4217                             s = d + 1;
4218                             goto its_constant;
4219                         }
4220                     }
4221                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4222                     PL_expect = XOPERATOR;
4223                     force_next(WORD);
4224                     yylval.ival = 0;
4225                     TOKEN('&');
4226                 }
4227
4228                 /* If followed by var or block, call it a method (unless sub) */
4229
4230                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4231                     PL_last_lop = PL_oldbufptr;
4232                     PL_last_lop_op = OP_METHOD;
4233                     PREBLOCK(METHOD);
4234                 }
4235
4236                 /* If followed by a bareword, see if it looks like indir obj. */
4237
4238                 if (!orig_keyword
4239                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4240                         && (tmp = intuit_method(s,gv)))
4241                     return REPORT(tmp);
4242
4243                 /* Not a method, so call it a subroutine (if defined) */
4244
4245                 if (gv && GvCVu(gv)) {
4246                     CV* cv;
4247                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4248                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4249                                 "Ambiguous use of -%s resolved as -&%s()",