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