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