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