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