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