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