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