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