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