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