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