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