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