toke.c

   1 /*    toke.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *   "It all comes from here, the stench and the peril."  --Frodo
  13  */
  14
  15 /*
  16  * This file is the lexer for Perl.  It's closely linked to the
  17  * parser, perly.y.
  18  *
  19  * The main routine is yylex(), which returns the next token.
  20  */
  21
  22 #include "EXTERN.h"
  23 #define PERL_IN_TOKE_C
  24 #include "perl.h"
  25
  26 #define yylval  (PL_parser->yylval)
  27
  28 /* YYINITDEPTH -- initial size of the parser's stacks.  */
  29 #define YYINITDEPTH 200
  30
  31 /* XXX temporary backwards compatibility */
  32 #define PL_lex_brackets         (PL_parser->lex_brackets)
  33 #define PL_lex_brackstack       (PL_parser->lex_brackstack)
  34 #define PL_lex_casemods         (PL_parser->lex_casemods)
  35 #define PL_lex_casestack        (PL_parser->lex_casestack)
  36 #define PL_lex_defer            (PL_parser->lex_defer)
  37 #define PL_lex_dojoin           (PL_parser->lex_dojoin)
  38 #define PL_lex_expect           (PL_parser->lex_expect)
  39 #define PL_lex_formbrack        (PL_parser->lex_formbrack)
  40 #define PL_lex_inpat            (PL_parser->lex_inpat)
  41 #define PL_lex_inwhat           (PL_parser->lex_inwhat)
  42 #define PL_lex_op               (PL_parser->lex_op)
  43 #define PL_lex_repl             (PL_parser->lex_repl)
  44 #define PL_lex_starts           (PL_parser->lex_starts)
  45 #define PL_lex_stuff            (PL_parser->lex_stuff)
  46 #define PL_multi_start          (PL_parser->multi_start)
  47 #define PL_multi_open           (PL_parser->multi_open)
  48 #define PL_multi_close          (PL_parser->multi_close)
  49 #define PL_pending_ident        (PL_parser->pending_ident)
  50 #define PL_preambled            (PL_parser->preambled)
  51 #define PL_sublex_info          (PL_parser->sublex_info)
  52
  53 #ifdef PERL_MAD
  54 #  define PL_endwhite           (PL_parser->endwhite)
  55 #  define PL_faketokens         (PL_parser->faketokens)
  56 #  define PL_lasttoke           (PL_parser->lasttoke)
  57 #  define PL_nextwhite          (PL_parser->nextwhite)
  58 #  define PL_realtokenstart     (PL_parser->realtokenstart)
  59 #  define PL_skipwhite          (PL_parser->skipwhite)
  60 #  define PL_thisclose          (PL_parser->thisclose)
  61 #  define PL_thismad            (PL_parser->thismad)
  62 #  define PL_thisopen           (PL_parser->thisopen)
  63 #  define PL_thisstuff          (PL_parser->thisstuff)
  64 #  define PL_thistoken          (PL_parser->thistoken)
  65 #  define PL_thiswhite          (PL_parser->thiswhite)
  66 #endif
  67
  68 static int
  69 S_pending_ident(pTHX);
  70
  71 static const char ident_too_long[] = "Identifier too long";
  72 static const char commaless_variable_list[] = "comma-less variable list";
  73
  74 static void restore_rsfp(pTHX_ void *f);
  75 #ifndef PERL_NO_UTF16_FILTER
  76 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  77 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  78 #endif
  79
  80 #ifdef PERL_MAD
  81 #  define CURMAD(slot,sv) if (PL_madskills) { curmad(slot,sv); sv = 0; }
  82 #  define NEXTVAL_NEXTTOKE PL_nexttoke[PL_curforce].next_val
  83 #else
  84 #  define CURMAD(slot,sv)
  85 #  define NEXTVAL_NEXTTOKE PL_nextval[PL_nexttoke]
  86 #endif
  87
  88 #define XFAKEBRACK 128
  89 #define XENUMMASK 127
  90
  91 #ifdef USE_UTF8_SCRIPTS
  92 #   define UTF (!IN_BYTES)
  93 #else
  94 #   define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
  95 #endif
  96
  97 /* In variables named $^X, these are the legal values for X.
  98  * 1999-02-27 mjd-perl-patch@plover.com */
  99 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
 100
 101 /* On MacOS, respect nonbreaking spaces */
 102 #ifdef MACOS_TRADITIONAL
 103 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
 104 #else
 105 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
 106 #endif
 107
 108 /* LEX_* are values for PL_lex_state, the state of the lexer.
 109  * They are arranged oddly so that the guard on the switch statement
 110  * can get by with a single comparison (if the compiler is smart enough).
 111  */
 112
 113 /* #define LEX_NOTPARSING               11 is done in perl.h. */
 114
 115 #define LEX_NORMAL              10 /* normal code (ie not within "...")     */
 116 #define LEX_INTERPNORMAL         9 /* code within a string, eg "$foo[$x+1]" */
 117 #define LEX_INTERPCASEMOD        8 /* expecting a \U, \Q or \E etc          */
 118 #define LEX_INTERPPUSH           7 /* starting a new sublex parse level     */
 119 #define LEX_INTERPSTART          6 /* expecting the start of a $var         */
 120
 121                                    /* at end of code, eg "$x" followed by:  */
 122 #define LEX_INTERPEND            5 /* ... eg not one of [, { or ->          */
 123 #define LEX_INTERPENDMAYBE       4 /* ... eg one of [, { or ->              */
 124
 125 #define LEX_INTERPCONCAT         3 /* expecting anything, eg at start of
 126                                         string or after \E, $foo, etc       */
 127 #define LEX_INTERPCONST          2 /* NOT USED */
 128 #define LEX_FORMLINE             1 /* expecting a format line               */
 129 #define LEX_KNOWNEXT             0 /* next token known; just return it      */
 130
 131
 132 #ifdef DEBUGGING
 133 static const char* const lex_state_names[] = {
 134     "KNOWNEXT",
 135     "FORMLINE",
 136     "INTERPCONST",
 137     "INTERPCONCAT",
 138     "INTERPENDMAYBE",
 139     "INTERPEND",
 140     "INTERPSTART",
 141     "INTERPPUSH",
 142     "INTERPCASEMOD",
 143     "INTERPNORMAL",
 144     "NORMAL"
 145 };
 146 #endif
 147
 148 #ifdef ff_next
 149 #undef ff_next
 150 #endif
 151
 152 #include "keywords.h"
 153
 154 /* CLINE is a macro that ensures PL_copline has a sane value */
 155
 156 #ifdef CLINE
 157 #undef CLINE
 158 #endif
 159 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
 160
 161 #ifdef PERL_MAD
 162 #  define SKIPSPACE0(s) skipspace0(s)
 163 #  define SKIPSPACE1(s) skipspace1(s)
 164 #  define SKIPSPACE2(s,tsv) skipspace2(s,&tsv)
 165 #  define PEEKSPACE(s) skipspace2(s,0)
 166 #else
 167 #  define SKIPSPACE0(s) skipspace(s)
 168 #  define SKIPSPACE1(s) skipspace(s)
 169 #  define SKIPSPACE2(s,tsv) skipspace(s)
 170 #  define PEEKSPACE(s) skipspace(s)
 171 #endif
 172
 173 /*
 174  * Convenience functions to return different tokens and prime the
 175  * lexer for the next token.  They all take an argument.
 176  *
 177  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
 178  * OPERATOR     : generic operator
 179  * AOPERATOR    : assignment operator
 180  * PREBLOCK     : beginning the block after an if, while, foreach, ...
 181  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
 182  * PREREF       : *EXPR where EXPR is not a simple identifier
 183  * TERM         : expression term
 184  * LOOPX        : loop exiting command (goto, last, dump, etc)
 185  * FTST         : file test operator
 186  * FUN0         : zero-argument function
 187  * FUN1         : not used, except for not, which isn't a UNIOP
 188  * BOop         : bitwise or or xor
 189  * BAop         : bitwise and
 190  * SHop         : shift operator
 191  * PWop         : power operator
 192  * PMop         : pattern-matching operator
 193  * Aop          : addition-level operator
 194  * Mop          : multiplication-level operator
 195  * Eop          : equality-testing operator
 196  * Rop          : relational operator <= != gt
 197  *
 198  * Also see LOP and lop() below.
 199  */
 200
 201 #ifdef DEBUGGING /* Serve -DT. */
 202 #   define REPORT(retval) tokereport((I32)retval)
 203 #else
 204 #   define REPORT(retval) (retval)
 205 #endif
 206
 207 #define TOKEN(retval) return ( PL_bufptr = s, REPORT(retval))
 208 #define OPERATOR(retval) return (PL_expect = XTERM, PL_bufptr = s, REPORT(retval))
 209 #define AOPERATOR(retval) return ao((PL_expect = XTERM, PL_bufptr = s, REPORT(retval)))
 210 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s, REPORT(retval))
 211 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s, REPORT(retval))
 212 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s, REPORT(retval))
 213 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR, PL_bufptr = s, REPORT(retval))
 214 #define LOOPX(f) return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)LOOPEX))
 215 #define FTST(f)  return (yylval.ival=f, PL_expect=XTERMORDORDOR, PL_bufptr=s, REPORT((int)UNIOP))
 216 #define FUN0(f)  return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC0))
 217 #define FUN1(f)  return (yylval.ival=f, PL_expect=XOPERATOR, PL_bufptr=s, REPORT((int)FUNC1))
 218 #define BOop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITOROP)))
 219 #define BAop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)BITANDOP)))
 220 #define SHop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)SHIFTOP)))
 221 #define PWop(f)  return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)POWOP)))
 222 #define PMop(f)  return(yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MATCHOP))
 223 #define Aop(f)   return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)ADDOP)))
 224 #define Mop(f)   return ao((yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)MULOP)))
 225 #define Eop(f)   return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)EQOP))
 226 #define Rop(f)   return (yylval.ival=f, PL_expect=XTERM, PL_bufptr=s, REPORT((int)RELOP))
 227
 228 /* This bit of chicanery makes a unary function followed by
 229  * a parenthesis into a function with one argument, highest precedence.
 230  * The UNIDOR macro is for unary functions that can be followed by the //
 231  * operator (such as C<shift // 0>).
 232  */
 233 #define UNI2(f,x) { \
 234         yylval.ival = f; \
 235         PL_expect = x; \
 236         PL_bufptr = s; \
 237         PL_last_uni = PL_oldbufptr; \
 238         PL_last_lop_op = f; \
 239         if (*s == '(') \
 240             return REPORT( (int)FUNC1 ); \
 241         s = PEEKSPACE(s); \
 242         return REPORT( *s=='(' ? (int)FUNC1 : (int)UNIOP ); \
 243         }
 244 #define UNI(f)    UNI2(f,XTERM)
 245 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
 246
 247 #define UNIBRACK(f) { \
 248         yylval.ival = f; \
 249         PL_bufptr = s; \
 250         PL_last_uni = PL_oldbufptr; \
 251         if (*s == '(') \
 252             return REPORT( (int)FUNC1 ); \
 253         s = PEEKSPACE(s); \
 254         return REPORT( (*s == '(') ? (int)FUNC1 : (int)UNIOP ); \
 255         }
 256
 257 /* grandfather return to old style */
 258 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
 259
 260 #ifdef DEBUGGING
 261
 262 /* how to interpret the yylval associated with the token */
 263 enum token_type {
 264     TOKENTYPE_NONE,
 265     TOKENTYPE_IVAL,
 266     TOKENTYPE_OPNUM, /* yylval.ival contains an opcode number */
 267     TOKENTYPE_PVAL,
 268     TOKENTYPE_OPVAL,
 269     TOKENTYPE_GVVAL
 270 };
 271
 272 static struct debug_tokens {
 273     const int token;
 274     enum token_type type;
 275     const char *name;
 276 } const debug_tokens[] =
 277 {
 278     { ADDOP,            TOKENTYPE_OPNUM,        "ADDOP" },
 279     { ANDAND,           TOKENTYPE_NONE,         "ANDAND" },
 280     { ANDOP,            TOKENTYPE_NONE,         "ANDOP" },
 281     { ANONSUB,          TOKENTYPE_IVAL,         "ANONSUB" },
 282     { ARROW,            TOKENTYPE_NONE,         "ARROW" },
 283     { ASSIGNOP,         TOKENTYPE_OPNUM,        "ASSIGNOP" },
 284     { BITANDOP,         TOKENTYPE_OPNUM,        "BITANDOP" },
 285     { BITOROP,          TOKENTYPE_OPNUM,        "BITOROP" },
 286     { COLONATTR,        TOKENTYPE_NONE,         "COLONATTR" },
 287     { CONTINUE,         TOKENTYPE_NONE,         "CONTINUE" },
 288     { DEFAULT,          TOKENTYPE_NONE,         "DEFAULT" },
 289     { DO,               TOKENTYPE_NONE,         "DO" },
 290     { DOLSHARP,         TOKENTYPE_NONE,         "DOLSHARP" },
 291     { DORDOR,           TOKENTYPE_NONE,         "DORDOR" },
 292     { DOROP,            TOKENTYPE_OPNUM,        "DOROP" },
 293     { DOTDOT,           TOKENTYPE_IVAL,         "DOTDOT" },
 294     { ELSE,             TOKENTYPE_NONE,         "ELSE" },
 295     { ELSIF,            TOKENTYPE_IVAL,         "ELSIF" },
 296     { EQOP,             TOKENTYPE_OPNUM,        "EQOP" },
 297     { FOR,              TOKENTYPE_IVAL,         "FOR" },
 298     { FORMAT,           TOKENTYPE_NONE,         "FORMAT" },
 299     { FUNC,             TOKENTYPE_OPNUM,        "FUNC" },
 300     { FUNC0,            TOKENTYPE_OPNUM,        "FUNC0" },
 301     { FUNC0SUB,         TOKENTYPE_OPVAL,        "FUNC0SUB" },
 302     { FUNC1,            TOKENTYPE_OPNUM,        "FUNC1" },
 303     { FUNCMETH,         TOKENTYPE_OPVAL,        "FUNCMETH" },
 304     { GIVEN,            TOKENTYPE_IVAL,         "GIVEN" },
 305     { HASHBRACK,        TOKENTYPE_NONE,         "HASHBRACK" },
 306     { IF,               TOKENTYPE_IVAL,         "IF" },
 307     { LABEL,            TOKENTYPE_PVAL,         "LABEL" },
 308     { LOCAL,            TOKENTYPE_IVAL,         "LOCAL" },
 309     { LOOPEX,           TOKENTYPE_OPNUM,        "LOOPEX" },
 310     { LSTOP,            TOKENTYPE_OPNUM,        "LSTOP" },
 311     { LSTOPSUB,         TOKENTYPE_OPVAL,        "LSTOPSUB" },
 312     { MATCHOP,          TOKENTYPE_OPNUM,        "MATCHOP" },
 313     { METHOD,           TOKENTYPE_OPVAL,        "METHOD" },
 314     { MULOP,            TOKENTYPE_OPNUM,        "MULOP" },
 315     { MY,               TOKENTYPE_IVAL,         "MY" },
 316     { MYSUB,            TOKENTYPE_NONE,         "MYSUB" },
 317     { NOAMP,            TOKENTYPE_NONE,         "NOAMP" },
 318     { NOTOP,            TOKENTYPE_NONE,         "NOTOP" },
 319     { OROP,             TOKENTYPE_IVAL,         "OROP" },
 320     { OROR,             TOKENTYPE_NONE,         "OROR" },
 321     { PACKAGE,          TOKENTYPE_NONE,         "PACKAGE" },
 322     { PMFUNC,           TOKENTYPE_OPVAL,        "PMFUNC" },
 323     { POSTDEC,          TOKENTYPE_NONE,         "POSTDEC" },
 324     { POSTINC,          TOKENTYPE_NONE,         "POSTINC" },
 325     { POWOP,            TOKENTYPE_OPNUM,        "POWOP" },
 326     { PREDEC,           TOKENTYPE_NONE,         "PREDEC" },
 327     { PREINC,           TOKENTYPE_NONE,         "PREINC" },
 328     { PRIVATEREF,       TOKENTYPE_OPVAL,        "PRIVATEREF" },
 329     { REFGEN,           TOKENTYPE_NONE,         "REFGEN" },
 330     { RELOP,            TOKENTYPE_OPNUM,        "RELOP" },
 331     { SHIFTOP,          TOKENTYPE_OPNUM,        "SHIFTOP" },
 332     { SUB,              TOKENTYPE_NONE,         "SUB" },
 333     { THING,            TOKENTYPE_OPVAL,        "THING" },
 334     { UMINUS,           TOKENTYPE_NONE,         "UMINUS" },
 335     { UNIOP,            TOKENTYPE_OPNUM,        "UNIOP" },
 336     { UNIOPSUB,         TOKENTYPE_OPVAL,        "UNIOPSUB" },
 337     { UNLESS,           TOKENTYPE_IVAL,         "UNLESS" },
 338     { UNTIL,            TOKENTYPE_IVAL,         "UNTIL" },
 339     { USE,              TOKENTYPE_IVAL,         "USE" },
 340     { WHEN,             TOKENTYPE_IVAL,         "WHEN" },
 341     { WHILE,            TOKENTYPE_IVAL,         "WHILE" },
 342     { WORD,             TOKENTYPE_OPVAL,        "WORD" },
 343     { 0,                TOKENTYPE_NONE,         NULL }
 344 };
 345
 346 /* dump the returned token in rv, plus any optional arg in yylval */
 347
 348 STATIC int
 349 S_tokereport(pTHX_ I32 rv)
 350 {
 351     dVAR;
 352     if (DEBUG_T_TEST) {
 353         const char *name = NULL;
 354         enum token_type type = TOKENTYPE_NONE;
 355         const struct debug_tokens *p;
 356         SV* const report = newSVpvs("<== ");
 357
 358         for (p = debug_tokens; p->token; p++) {
 359             if (p->token == (int)rv) {
 360                 name = p->name;
 361                 type = p->type;
 362                 break;
 363             }
 364         }
 365         if (name)
 366             Perl_sv_catpv(aTHX_ report, name);
 367         else if ((char)rv > ' ' && (char)rv < '~')
 368             Perl_sv_catpvf(aTHX_ report, "'%c'", (char)rv);
 369         else if (!rv)
 370             sv_catpvs(report, "EOF");
 371         else
 372             Perl_sv_catpvf(aTHX_ report, "?? %"IVdf, (IV)rv);
 373         switch (type) {
 374         case TOKENTYPE_NONE:
 375         case TOKENTYPE_GVVAL: /* doesn't appear to be used */
 376             break;
 377         case TOKENTYPE_IVAL:
 378             Perl_sv_catpvf(aTHX_ report, "(ival=%"IVdf")", (IV)yylval.ival);
 379             break;
 380         case TOKENTYPE_OPNUM:
 381             Perl_sv_catpvf(aTHX_ report, "(ival=op_%s)",
 382                                     PL_op_name[yylval.ival]);
 383             break;
 384         case TOKENTYPE_PVAL:
 385             Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
 386             break;
 387         case TOKENTYPE_OPVAL:
 388             if (yylval.opval) {
 389                 Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
 390                                     PL_op_name[yylval.opval->op_type]);
 391                 if (yylval.opval->op_type == OP_CONST) {
 392                     Perl_sv_catpvf(aTHX_ report, " %s",
 393                         SvPEEK(cSVOPx_sv(yylval.opval)));
 394                 }
 395
 396             }
 397             else
 398                 sv_catpvs(report, "(opval=null)");
 399             break;
 400         }
 401         PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
 402     };
 403     return (int)rv;
 404 }
 405
 406
 407 /* print the buffer with suitable escapes */
 408
 409 STATIC void
 410 S_printbuf(pTHX_ const char* fmt, const char* s)
 411 {
 412     SV* const tmp = newSVpvs("");
 413     PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
 414     SvREFCNT_dec(tmp);
 415 }
 416
 417 #endif
 418
 419 /*
 420  * S_ao
 421  *
 422  * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
 423  * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
 424  */
 425
 426 STATIC int
 427 S_ao(pTHX_ int toketype)
 428 {
 429     dVAR;
 430     if (*PL_bufptr == '=') {
 431         PL_bufptr++;
 432         if (toketype == ANDAND)
 433             yylval.ival = OP_ANDASSIGN;
 434         else if (toketype == OROR)
 435             yylval.ival = OP_ORASSIGN;
 436         else if (toketype == DORDOR)
 437             yylval.ival = OP_DORASSIGN;
 438         toketype = ASSIGNOP;
 439     }
 440     return toketype;
 441 }
 442
 443 /*
 444  * S_no_op
 445  * When Perl expects an operator and finds something else, no_op
 446  * prints the warning.  It always prints "<something> found where
 447  * operator expected.  It prints "Missing semicolon on previous line?"
 448  * if the surprise occurs at the start of the line.  "do you need to
 449  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
 450  * where the compiler doesn't know if foo is a method call or a function.
 451  * It prints "Missing operator before end of line" if there's nothing
 452  * after the missing operator, or "... before <...>" if there is something
 453  * after the missing operator.
 454  */
 455
 456 STATIC void
 457 S_no_op(pTHX_ const char *what, char *s)
 458 {
 459     dVAR;
 460     char * const oldbp = PL_bufptr;
 461     const bool is_first = (PL_oldbufptr == PL_linestart);
 462
 463     if (!s)
 464         s = oldbp;
 465     else
 466         PL_bufptr = s;
 467     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
 468     if (ckWARN_d(WARN_SYNTAX)) {
 469         if (is_first)
 470             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 471                     "\t(Missing semicolon on previous line?)\n");
 472         else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
 473             const char *t;
 474             for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++)
 475                 NOOP;
 476             if (t < PL_bufptr && isSPACE(*t))
 477                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 478                         "\t(Do you need to predeclare %.*s?)\n",
 479                     (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
 480         }
 481         else {
 482             assert(s >= oldbp);
 483             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 484                     "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
 485         }
 486     }
 487     PL_bufptr = oldbp;
 488 }
 489
 490 /*
 491  * S_missingterm
 492  * Complain about missing quote/regexp/heredoc terminator.
 493  * If it's called with NULL then it cauterizes the line buffer.
 494  * If we're in a delimited string and the delimiter is a control
 495  * character, it's reformatted into a two-char sequence like ^C.
 496  * This is fatal.
 497  */
 498
 499 STATIC void
 500 S_missingterm(pTHX_ char *s)
 501 {
 502     dVAR;
 503     char tmpbuf[3];
 504     char q;
 505     if (s) {
 506         char * const nl = strrchr(s,'\n');
 507         if (nl)
 508             *nl = '\0';
 509     }
 510     else if (
 511 #ifdef EBCDIC
 512         iscntrl(PL_multi_close)
 513 #else
 514         PL_multi_close < 32 || PL_multi_close == 127
 515 #endif
 516         ) {
 517         *tmpbuf = '^';
 518         tmpbuf[1] = (char)toCTRL(PL_multi_close);
 519         tmpbuf[2] = '\0';
 520         s = tmpbuf;
 521     }
 522     else {
 523         *tmpbuf = (char)PL_multi_close;
 524         tmpbuf[1] = '\0';
 525         s = tmpbuf;
 526     }
 527     q = strchr(s,'"') ? '\'' : '"';
 528     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 529 }
 530
 531 #define FEATURE_IS_ENABLED(name)                                        \
 532         ((0 != (PL_hints & HINT_LOCALIZE_HH))                           \
 533             && S_feature_is_enabled(aTHX_ STR_WITH_LEN(name)))
 534 /*
 535  * S_feature_is_enabled
 536  * Check whether the named feature is enabled.
 537  */
 538 STATIC bool
 539 S_feature_is_enabled(pTHX_ const char *name, STRLEN namelen)
 540 {
 541     dVAR;
 542     HV * const hinthv = GvHV(PL_hintgv);
 543     char he_name[32] = "feature_";
 544     (void) my_strlcpy(&he_name[8], name, 24);
 545
 546     return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
 547 }
 548
 549 /*
 550  * Perl_deprecate
 551  */
 552
 553 void
 554 Perl_deprecate(pTHX_ const char *s)
 555 {
 556     if (ckWARN(WARN_DEPRECATED))
 557         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
 558 }
 559
 560 void
 561 Perl_deprecate_old(pTHX_ const char *s)
 562 {
 563     /* This function should NOT be called for any new deprecated warnings */
 564     /* Use Perl_deprecate instead                                         */
 565     /*                                                                    */
 566     /* It is here to maintain backward compatibility with the pre-5.8     */
 567     /* warnings category hierarchy. The "deprecated" category used to     */
 568     /* live under the "syntax" category. It is now a top-level category   */
 569     /* in its own right.                                                  */
 570
 571     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 572         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 573                         "Use of %s is deprecated", s);
 574 }
 575
 576 /*
 577  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
 578  * utf16-to-utf8-reversed.
 579  */
 580
 581 #ifdef PERL_CR_FILTER
 582 static void
 583 strip_return(SV *sv)
 584 {
 585     register const char *s = SvPVX_const(sv);
 586     register const char * const e = s + SvCUR(sv);
 587     /* outer loop optimized to do nothing if there are no CR-LFs */
 588     while (s < e) {
 589         if (*s++ == '\r' && *s == '\n') {
 590             /* hit a CR-LF, need to copy the rest */
 591             register char *d = s - 1;
 592             *d++ = *s++;
 593             while (s < e) {
 594                 if (*s == '\r' && s[1] == '\n')
 595                     s++;
 596                 *d++ = *s++;
 597             }
 598             SvCUR(sv) -= s - d;
 599             return;
 600         }
 601     }
 602 }
 603
 604 STATIC I32
 605 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 606 {
 607     const I32 count = FILTER_READ(idx+1, sv, maxlen);
 608     if (count > 0 && !maxlen)
 609         strip_return(sv);
 610     return count;
 611 }
 612 #endif
 613
 614
 615
 616 /*
 617  * Perl_lex_start
 618  * Initialize variables.  Uses the Perl save_stack to save its state (for
 619  * recursive calls to the parser).
 620  */
 621
 622 void
 623 Perl_lex_start(pTHX_ SV *line)
 624 {
 625     dVAR;
 626     const char *s = NULL;
 627     STRLEN len;
 628     yy_parser *parser;
 629
 630     /* create and initialise a parser */
 631
 632     Newxz(parser, 1, yy_parser);
 633     parser->old_parser = PL_parser;
 634     PL_parser = parser;
 635
 636     Newx(parser->stack, YYINITDEPTH, yy_stack_frame);
 637     parser->ps = parser->stack;
 638     parser->stack_size = YYINITDEPTH;
 639
 640     parser->stack->state = 0;
 641     parser->yyerrstatus = 0;
 642     parser->yychar = YYEMPTY;           /* Cause a token to be read.  */
 643
 644     /* initialise lexer state */
 645
 646     SAVEI32(PL_lex_state);
 647 #ifdef PERL_MAD
 648     if (PL_lex_state == LEX_KNOWNEXT) {
 649         I32 toke = parser->old_parser->lasttoke;
 650         while (--toke >= 0) {
 651             SAVEI32(PL_nexttoke[toke].next_type);
 652             SAVEVPTR(PL_nexttoke[toke].next_val);
 653             if (PL_madskills)
 654                 SAVEVPTR(PL_nexttoke[toke].next_mad);
 655         }
 656     }
 657     SAVEI32(PL_curforce);
 658 #else
 659     if (PL_lex_state == LEX_KNOWNEXT) {
 660         I32 toke = PL_nexttoke;
 661         while (--toke >= 0) {
 662             SAVEI32(PL_nexttype[toke]);
 663             SAVEVPTR(PL_nextval[toke]);
 664         }
 665         SAVEI32(PL_nexttoke);
 666     }
 667 #endif
 668     SAVECOPLINE(PL_curcop);
 669     SAVEPPTR(PL_bufptr);
 670     SAVEPPTR(PL_bufend);
 671     SAVEPPTR(PL_oldbufptr);
 672     SAVEPPTR(PL_oldoldbufptr);
 673     SAVEPPTR(PL_last_lop);
 674     SAVEPPTR(PL_last_uni);
 675     SAVEPPTR(PL_linestart);
 676     SAVESPTR(PL_linestr);
 677     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
 678     SAVEINT(PL_expect);
 679
 680     PL_lex_state = LEX_NORMAL;
 681     PL_expect = XSTATE;
 682     Newx(parser->lex_brackstack, 120, char);
 683     Newx(parser->lex_casestack, 12, char);
 684     *parser->lex_casestack = '\0';
 685 #ifndef PERL_MAD
 686     PL_nexttoke = 0;
 687 #endif
 688
 689     if (line) {
 690         s = SvPV_const(line, len);
 691     } else {
 692         len = 0;
 693     }
 694     if (!len) {
 695         PL_linestr = newSVpvs("\n;");
 696     } else if (SvREADONLY(line) || s[len-1] != ';') {
 697         PL_linestr = newSVsv(line);
 698         if (s[len-1] != ';')
 699             sv_catpvs(PL_linestr, "\n;");
 700     } else {
 701         SvTEMP_off(line);
 702         SvREFCNT_inc_simple_void_NN(line);
 703         PL_linestr = line;
 704     }
 705     /* PL_linestr needs to survive until end of scope, not just the next
 706        FREETMPS. See changes 17505 and 17546 which fixed the symptoms only.  */
 707     SAVEFREESV(PL_linestr);
 708     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
 709     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
 710     PL_last_lop = PL_last_uni = NULL;
 711     PL_rsfp = 0;
 712 }
 713
 714 /*
 715  * Perl_lex_end
 716  * Finalizer for lexing operations.  Must be called when the parser is
 717  * done with the lexer.
 718  */
 719
 720 void
 721 Perl_lex_end(pTHX)
 722 {
 723     dVAR;
 724     PL_doextract = FALSE;
 725 }
 726
 727 /*
 728  * S_incline
 729  * This subroutine has nothing to do with tilting, whether at windmills
 730  * or pinball tables.  Its name is short for "increment line".  It
 731  * increments the current line number in CopLINE(PL_curcop) and checks
 732  * to see whether the line starts with a comment of the form
 733  *    # line 500 "foo.pm"
 734  * If so, it sets the current line number and file to the values in the comment.
 735  */
 736
 737 STATIC void
 738 S_incline(pTHX_ char *s)
 739 {
 740     dVAR;
 741     char *t;
 742     char *n;
 743     char *e;
 744     char ch;
 745
 746     CopLINE_inc(PL_curcop);
 747     if (*s++ != '#')
 748         return;
 749     while (SPACE_OR_TAB(*s))
 750         s++;
 751     if (strnEQ(s, "line", 4))
 752         s += 4;
 753     else
 754         return;
 755     if (SPACE_OR_TAB(*s))
 756         s++;
 757     else
 758         return;
 759     while (SPACE_OR_TAB(*s))
 760         s++;
 761     if (!isDIGIT(*s))
 762         return;
 763
 764     n = s;
 765     while (isDIGIT(*s))
 766         s++;
 767     while (SPACE_OR_TAB(*s))
 768         s++;
 769     if (*s == '"' && (t = strchr(s+1, '"'))) {
 770         s++;
 771         e = t + 1;
 772     }
 773     else {
 774         t = s;
 775         while (!isSPACE(*t))
 776             t++;
 777         e = t;
 778     }
 779     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
 780         e++;
 781     if (*e != '\n' && *e != '\0')
 782         return;         /* false alarm */
 783
 784     ch = *t;
 785     *t = '\0';
 786     if (t - s > 0) {
 787 #ifndef USE_ITHREADS
 788         const char * const cf = CopFILE(PL_curcop);
 789         STRLEN tmplen = cf ? strlen(cf) : 0;
 790         if (tmplen > 7 && strnEQ(cf, "(eval ", 6)) {
 791             /* must copy *{"::_<(eval N)[oldfilename:L]"}
 792              * to *{"::_<newfilename"} */
 793             char smallbuf[256], smallbuf2[256];
 794             char *tmpbuf, *tmpbuf2;
 795             GV **gvp, *gv2;
 796             STRLEN tmplen2 = strlen(s);
 797             if (tmplen + 3 < sizeof smallbuf)
 798                 tmpbuf = smallbuf;
 799             else
 800                 Newx(tmpbuf, tmplen + 3, char);
 801             if (tmplen2 + 3 < sizeof smallbuf2)
 802                 tmpbuf2 = smallbuf2;
 803             else
 804                 Newx(tmpbuf2, tmplen2 + 3, char);
 805             tmpbuf[0] = tmpbuf2[0] = '_';
 806             tmpbuf[1] = tmpbuf2[1] = '<';
 807             memcpy(tmpbuf + 2, cf, ++tmplen);
 808             memcpy(tmpbuf2 + 2, s, ++tmplen2);
 809             ++tmplen; ++tmplen2;
 810             gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
 811             if (gvp) {
 812                 gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
 813                 if (!isGV(gv2)) {
 814                     gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
 815                     /* adjust ${"::_<newfilename"} to store the new file name */
 816                     GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
 817                     GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
 818                     GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
 819                 }
 820             }
 821             if (tmpbuf != smallbuf) Safefree(tmpbuf);
 822             if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
 823         }
 824 #endif
 825         CopFILE_free(PL_curcop);
 826         CopFILE_set(PL_curcop, s);
 827     }
 828     *t = ch;
 829     CopLINE_set(PL_curcop, atoi(n)-1);
 830 }
 831
 832 #ifdef PERL_MAD
 833 /* skip space before PL_thistoken */
 834
 835 STATIC char *
 836 S_skipspace0(pTHX_ register char *s)
 837 {
 838     s = skipspace(s);
 839     if (!PL_madskills)
 840         return s;
 841     if (PL_skipwhite) {
 842         if (!PL_thiswhite)
 843             PL_thiswhite = newSVpvs("");
 844         sv_catsv(PL_thiswhite, PL_skipwhite);
 845         sv_free(PL_skipwhite);
 846         PL_skipwhite = 0;
 847     }
 848     PL_realtokenstart = s - SvPVX(PL_linestr);
 849     return s;
 850 }
 851
 852 /* skip space after PL_thistoken */
 853
 854 STATIC char *
 855 S_skipspace1(pTHX_ register char *s)
 856 {
 857     const char *start = s;
 858     I32 startoff = start - SvPVX(PL_linestr);
 859
 860     s = skipspace(s);
 861     if (!PL_madskills)
 862         return s;
 863     start = SvPVX(PL_linestr) + startoff;
 864     if (!PL_thistoken && PL_realtokenstart >= 0) {
 865         const char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
 866         PL_thistoken = newSVpvn(tstart, start - tstart);
 867     }
 868     PL_realtokenstart = -1;
 869     if (PL_skipwhite) {
 870         if (!PL_nextwhite)
 871             PL_nextwhite = newSVpvs("");
 872         sv_catsv(PL_nextwhite, PL_skipwhite);
 873         sv_free(PL_skipwhite);
 874         PL_skipwhite = 0;
 875     }
 876     return s;
 877 }
 878
 879 STATIC char *
 880 S_skipspace2(pTHX_ register char *s, SV **svp)
 881 {
 882     char *start;
 883     const I32 bufptroff = PL_bufptr - SvPVX(PL_linestr);
 884     const I32 startoff = s - SvPVX(PL_linestr);
 885
 886     s = skipspace(s);
 887     PL_bufptr = SvPVX(PL_linestr) + bufptroff;
 888     if (!PL_madskills || !svp)
 889         return s;
 890     start = SvPVX(PL_linestr) + startoff;
 891     if (!PL_thistoken && PL_realtokenstart >= 0) {
 892         char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
 893         PL_thistoken = newSVpvn(tstart, start - tstart);
 894         PL_realtokenstart = -1;
 895     }
 896     if (PL_skipwhite) {
 897         if (!*svp)
 898             *svp = newSVpvs("");
 899         sv_setsv(*svp, PL_skipwhite);
 900         sv_free(PL_skipwhite);
 901         PL_skipwhite = 0;
 902     }
 903
 904     return s;
 905 }
 906 #endif
 907
 908 STATIC void
 909 S_update_debugger_info(pTHX_ SV *orig_sv, const char *buf, STRLEN len)
 910 {
 911     AV *av = CopFILEAVx(PL_curcop);
 912     if (av) {
 913         SV * const sv = newSV(0);
 914         sv_upgrade(sv, SVt_PVMG);
 915         if (orig_sv)
 916             sv_setsv(sv, orig_sv);
 917         else
 918             sv_setpvn(sv, buf, len);
 919         (void)SvIOK_on(sv);
 920         SvIV_set(sv, 0);
 921         av_store(av, (I32)CopLINE(PL_curcop), sv);
 922     }
 923 }
 924
 925 /*
 926  * S_skipspace
 927  * Called to gobble the appropriate amount and type of whitespace.
 928  * Skips comments as well.
 929  */
 930
 931 STATIC char *
 932 S_skipspace(pTHX_ register char *s)
 933 {
 934     dVAR;
 935 #ifdef PERL_MAD
 936     int curoff;
 937     int startoff = s - SvPVX(PL_linestr);
 938
 939     if (PL_skipwhite) {
 940         sv_free(PL_skipwhite);
 941         PL_skipwhite = 0;
 942     }
 943 #endif
 944
 945     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 946         while (s < PL_bufend && SPACE_OR_TAB(*s))
 947             s++;
 948 #ifdef PERL_MAD
 949         goto done;
 950 #else
 951         return s;
 952 #endif
 953     }
 954     for (;;) {
 955         STRLEN prevlen;
 956         SSize_t oldprevlen, oldoldprevlen;
 957         SSize_t oldloplen = 0, oldunilen = 0;
 958         while (s < PL_bufend && isSPACE(*s)) {
 959             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
 960                 incline(s);
 961         }
 962
 963         /* comment */
 964         if (s < PL_bufend && *s == '#') {
 965             while (s < PL_bufend && *s != '\n')
 966                 s++;
 967             if (s < PL_bufend) {
 968                 s++;
 969                 if (PL_in_eval && !PL_rsfp) {
 970                     incline(s);
 971                     continue;
 972                 }
 973             }
 974         }
 975
 976         /* only continue to recharge the buffer if we're at the end
 977          * of the buffer, we're not reading from a source filter, and
 978          * we're in normal lexing mode
 979          */
 980         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
 981                 PL_lex_state == LEX_FORMLINE)
 982 #ifdef PERL_MAD
 983             goto done;
 984 #else
 985             return s;
 986 #endif
 987
 988         /* try to recharge the buffer */
 989 #ifdef PERL_MAD
 990         curoff = s - SvPVX(PL_linestr);
 991 #endif
 992
 993         if ((s = filter_gets(PL_linestr, PL_rsfp,
 994                              (prevlen = SvCUR(PL_linestr)))) == NULL)
 995         {
 996 #ifdef PERL_MAD
 997             if (PL_madskills && curoff != startoff) {
 998                 if (!PL_skipwhite)
 999                     PL_skipwhite = newSVpvs("");
1000                 sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1001                                         curoff - startoff);
1002             }
1003
1004             /* mustn't throw out old stuff yet if madpropping */
1005             SvCUR(PL_linestr) = curoff;
1006             s = SvPVX(PL_linestr) + curoff;
1007             *s = 0;
1008             if (curoff && s[-1] == '\n')
1009                 s[-1] = ' ';
1010 #endif
1011
1012             /* end of file.  Add on the -p or -n magic */
1013             /* XXX these shouldn't really be added here, can't set PL_faketokens */
1014             if (PL_minus_p) {
1015 #ifdef PERL_MAD
1016                 sv_catpv(PL_linestr,
1017                          ";}continue{print or die qq(-p destination: $!\\n);}");
1018 #else
1019                 sv_setpv(PL_linestr,
1020                          ";}continue{print or die qq(-p destination: $!\\n);}");
1021 #endif
1022                 PL_minus_n = PL_minus_p = 0;
1023             }
1024             else if (PL_minus_n) {
1025 #ifdef PERL_MAD
1026                 sv_catpvn(PL_linestr, ";}", 2);
1027 #else
1028                 sv_setpvn(PL_linestr, ";}", 2);
1029 #endif
1030                 PL_minus_n = 0;
1031             }
1032             else
1033 #ifdef PERL_MAD
1034                 sv_catpvn(PL_linestr,";", 1);
1035 #else
1036                 sv_setpvn(PL_linestr,";", 1);
1037 #endif
1038
1039             /* reset variables for next time we lex */
1040             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
1041                 = SvPVX(PL_linestr)
1042 #ifdef PERL_MAD
1043                 + curoff
1044 #endif
1045                 ;
1046             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1047             PL_last_lop = PL_last_uni = NULL;
1048
1049             /* Close the filehandle.  Could be from -P preprocessor,
1050              * STDIN, or a regular file.  If we were reading code from
1051              * STDIN (because the commandline held no -e or filename)
1052              * then we don't close it, we reset it so the code can
1053              * read from STDIN too.
1054              */
1055
1056             if (PL_preprocess && !PL_in_eval)
1057                 (void)PerlProc_pclose(PL_rsfp);
1058             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
1059                 PerlIO_clearerr(PL_rsfp);
1060             else
1061                 (void)PerlIO_close(PL_rsfp);
1062             PL_rsfp = NULL;
1063             return s;
1064         }
1065
1066         /* not at end of file, so we only read another line */
1067         /* make corresponding updates to old pointers, for yyerror() */
1068         oldprevlen = PL_oldbufptr - PL_bufend;
1069         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
1070         if (PL_last_uni)
1071             oldunilen = PL_last_uni - PL_bufend;
1072         if (PL_last_lop)
1073             oldloplen = PL_last_lop - PL_bufend;
1074         PL_linestart = PL_bufptr = s + prevlen;
1075         PL_bufend = s + SvCUR(PL_linestr);
1076         s = PL_bufptr;
1077         PL_oldbufptr = s + oldprevlen;
1078         PL_oldoldbufptr = s + oldoldprevlen;
1079         if (PL_last_uni)
1080             PL_last_uni = s + oldunilen;
1081         if (PL_last_lop)
1082             PL_last_lop = s + oldloplen;
1083         incline(s);
1084
1085         /* debugger active and we're not compiling the debugger code,
1086          * so store the line into the debugger's array of lines
1087          */
1088         if (PERLDB_LINE && PL_curstash != PL_debstash)
1089             update_debugger_info(NULL, PL_bufptr, PL_bufend - PL_bufptr);
1090     }
1091
1092 #ifdef PERL_MAD
1093   done:
1094     if (PL_madskills) {
1095         if (!PL_skipwhite)
1096             PL_skipwhite = newSVpvs("");
1097         curoff = s - SvPVX(PL_linestr);
1098         if (curoff - startoff)
1099             sv_catpvn(PL_skipwhite, SvPVX(PL_linestr) + startoff,
1100                                 curoff - startoff);
1101     }
1102     return s;
1103 #endif
1104 }
1105
1106 /*
1107  * S_check_uni
1108  * Check the unary operators to ensure there's no ambiguity in how they're
1109  * used.  An ambiguous piece of code would be:
1110  *     rand + 5
1111  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
1112  * the +5 is its argument.
1113  */
1114
1115 STATIC void
1116 S_check_uni(pTHX)
1117 {
1118     dVAR;
1119     const char *s;
1120     const char *t;
1121
1122     if (PL_oldoldbufptr != PL_last_uni)
1123         return;
1124     while (isSPACE(*PL_last_uni))
1125         PL_last_uni++;
1126     s = PL_last_uni;
1127     while (isALNUM_lazy_if(s,UTF) || *s == '-')
1128         s++;
1129     if ((t = strchr(s, '(')) && t < PL_bufptr)
1130         return;
1131
1132     if (ckWARN_d(WARN_AMBIGUOUS)){
1133         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
1134                    "Warning: Use of \"%.*s\" without parentheses is ambiguous",
1135                    (int)(s - PL_last_uni), PL_last_uni);
1136     }
1137 }
1138
1139 /*
1140  * LOP : macro to build a list operator.  Its behaviour has been replaced
1141  * with a subroutine, S_lop() for which LOP is just another name.
1142  */
1143
1144 #define LOP(f,x) return lop(f,x,s)
1145
1146 /*
1147  * S_lop
1148  * Build a list operator (or something that might be one).  The rules:
1149  *  - if we have a next token, then it's a list operator [why?]
1150  *  - if the next thing is an opening paren, then it's a function
1151  *  - else it's a list operator
1152  */
1153
1154 STATIC I32
1155 S_lop(pTHX_ I32 f, int x, char *s)
1156 {
1157     dVAR;
1158     yylval.ival = f;
1159     CLINE;
1160     PL_expect = x;
1161     PL_bufptr = s;
1162     PL_last_lop = PL_oldbufptr;
1163     PL_last_lop_op = (OPCODE)f;
1164 #ifdef PERL_MAD
1165     if (PL_lasttoke)
1166         return REPORT(LSTOP);
1167 #else
1168     if (PL_nexttoke)
1169         return REPORT(LSTOP);
1170 #endif
1171     if (*s == '(')
1172         return REPORT(FUNC);
1173     s = PEEKSPACE(s);
1174     if (*s == '(')
1175         return REPORT(FUNC);
1176     else
1177         return REPORT(LSTOP);
1178 }
1179
1180 #ifdef PERL_MAD
1181  /*
1182  * S_start_force
1183  * Sets up for an eventual force_next().  start_force(0) basically does
1184  * an unshift, while start_force(-1) does a push.  yylex removes items
1185  * on the "pop" end.
1186  */
1187
1188 STATIC void
1189 S_start_force(pTHX_ int where)
1190 {
1191     int i;
1192
1193     if (where < 0)      /* so people can duplicate start_force(PL_curforce) */
1194         where = PL_lasttoke;
1195     assert(PL_curforce < 0 || PL_curforce == where);
1196     if (PL_curforce != where) {
1197         for (i = PL_lasttoke; i > where; --i) {
1198             PL_nexttoke[i] = PL_nexttoke[i-1];
1199         }
1200         PL_lasttoke++;
1201     }
1202     if (PL_curforce < 0)        /* in case of duplicate start_force() */
1203         Zero(&PL_nexttoke[where], 1, NEXTTOKE);
1204     PL_curforce = where;
1205     if (PL_nextwhite) {
1206         if (PL_madskills)
1207             curmad('^', newSVpvs(""));
1208         CURMAD('_', PL_nextwhite);
1209     }
1210 }
1211
1212 STATIC void
1213 S_curmad(pTHX_ char slot, SV *sv)
1214 {
1215     MADPROP **where;
1216
1217     if (!sv)
1218         return;
1219     if (PL_curforce < 0)
1220         where = &PL_thismad;
1221     else
1222         where = &PL_nexttoke[PL_curforce].next_mad;
1223
1224     if (PL_faketokens)
1225         sv_setpvn(sv, "", 0);
1226     else {
1227         if (!IN_BYTES) {
1228             if (UTF && is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
1229                 SvUTF8_on(sv);
1230             else if (PL_encoding) {
1231                 sv_recode_to_utf8(sv, PL_encoding);
1232             }
1233         }
1234     }
1235
1236     /* keep a slot open for the head of the list? */
1237     if (slot != '_' && *where && (*where)->mad_key == '^') {
1238         (*where)->mad_key = slot;
1239         sv_free((*where)->mad_val);
1240         (*where)->mad_val = (void*)sv;
1241     }
1242     else
1243         addmad(newMADsv(slot, sv), where, 0);
1244 }
1245 #else
1246 #  define start_force(where)    NOOP
1247 #  define curmad(slot, sv)      NOOP
1248 #endif
1249
1250 /*
1251  * S_force_next
1252  * When the lexer realizes it knows the next token (for instance,
1253  * it is reordering tokens for the parser) then it can call S_force_next
1254  * to know what token to return the next time the lexer is called.  Caller
1255  * will need to set PL_nextval[] (or PL_nexttoke[].next_val with PERL_MAD),
1256  * and possibly PL_expect to ensure the lexer handles the token correctly.
1257  */
1258
1259 STATIC void
1260 S_force_next(pTHX_ I32 type)
1261 {
1262     dVAR;
1263 #ifdef PERL_MAD
1264     if (PL_curforce < 0)
1265         start_force(PL_lasttoke);
1266     PL_nexttoke[PL_curforce].next_type = type;
1267     if (PL_lex_state != LEX_KNOWNEXT)
1268         PL_lex_defer = PL_lex_state;
1269     PL_lex_state = LEX_KNOWNEXT;
1270     PL_lex_expect = PL_expect;
1271     PL_curforce = -1;
1272 #else
1273     PL_nexttype[PL_nexttoke] = type;
1274     PL_nexttoke++;
1275     if (PL_lex_state != LEX_KNOWNEXT) {
1276         PL_lex_defer = PL_lex_state;
1277         PL_lex_expect = PL_expect;
1278         PL_lex_state = LEX_KNOWNEXT;
1279     }
1280 #endif
1281 }
1282
1283 STATIC SV *
1284 S_newSV_maybe_utf8(pTHX_ const char *start, STRLEN len)
1285 {
1286     dVAR;
1287     SV * const sv = newSVpvn(start,len);
1288     if (UTF && !IN_BYTES && is_utf8_string((const U8*)start, len))
1289         SvUTF8_on(sv);
1290     return sv;
1291 }
1292
1293 /*
1294  * S_force_word
1295  * When the lexer knows the next thing is a word (for instance, it has
1296  * just seen -> and it knows that the next char is a word char, then
1297  * it calls S_force_word to stick the next word into the PL_nexttoke/val
1298  * lookahead.
1299  *
1300  * Arguments:
1301  *   char *start : buffer position (must be within PL_linestr)
1302  *   int token   : PL_next* will be this type of bare word (e.g., METHOD,WORD)
1303  *   int check_keyword : if true, Perl checks to make sure the word isn't
1304  *       a keyword (do this if the word is a label, e.g. goto FOO)
1305  *   int allow_pack : if true, : characters will also be allowed (require,
1306  *       use, etc. do this)
1307  *   int allow_initial_tick : used by the "sub" lexer only.
1308  */
1309
1310 STATIC char *
1311 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
1312 {
1313     dVAR;
1314     register char *s;
1315     STRLEN len;
1316
1317     start = SKIPSPACE1(start);
1318     s = start;
1319     if (isIDFIRST_lazy_if(s,UTF) ||
1320         (allow_pack && *s == ':') ||
1321         (allow_initial_tick && *s == '\'') )
1322     {
1323         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
1324         if (check_keyword && keyword(PL_tokenbuf, len, 0))
1325             return start;
1326         start_force(PL_curforce);
1327         if (PL_madskills)
1328             curmad('X', newSVpvn(start,s-start));
1329         if (token == METHOD) {
1330             s = SKIPSPACE1(s);
1331             if (*s == '(')
1332                 PL_expect = XTERM;
1333             else {
1334                 PL_expect = XOPERATOR;
1335             }
1336         }
1337         NEXTVAL_NEXTTOKE.opval
1338             = (OP*)newSVOP(OP_CONST,0,
1339                            S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
1340         NEXTVAL_NEXTTOKE.opval->op_private |= OPpCONST_BARE;
1341         force_next(token);
1342     }
1343     return s;
1344 }
1345
1346 /*
1347  * S_force_ident
1348  * Called when the lexer wants $foo *foo &foo etc, but the program
1349  * text only contains the "foo" portion.  The first argument is a pointer
1350  * to the "foo", and the second argument is the type symbol to prefix.
1351  * Forces the next token to be a "WORD".
1352  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
1353  */
1354
1355 STATIC void
1356 S_force_ident(pTHX_ register const char *s, int kind)
1357 {
1358     dVAR;
1359     if (*s) {
1360         const STRLEN len = strlen(s);
1361         OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len));
1362         start_force(PL_curforce);
1363         NEXTVAL_NEXTTOKE.opval = o;
1364         force_next(WORD);
1365         if (kind) {
1366             o->op_private = OPpCONST_ENTERED;
1367             /* XXX see note in pp_entereval() for why we forgo typo
1368                warnings if the symbol must be introduced in an eval.
1369                GSAR 96-10-12 */
1370             gv_fetchpvn_flags(s, len,
1371                               PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL)
1372                               : GV_ADD,
1373                               kind == '$' ? SVt_PV :
1374                               kind == '@' ? SVt_PVAV :
1375                               kind == '%' ? SVt_PVHV :
1376                               SVt_PVGV
1377                               );
1378         }
1379     }
1380 }
1381
1382 NV
1383 Perl_str_to_version(pTHX_ SV *sv)
1384 {
1385     NV retval = 0.0;
1386     NV nshift = 1.0;
1387     STRLEN len;
1388     const char *start = SvPV_const(sv,len);
1389     const char * const end = start + len;
1390     const bool utf = SvUTF8(sv) ? TRUE : FALSE;
1391     while (start < end) {
1392         STRLEN skip;
1393         UV n;
1394         if (utf)
1395             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
1396         else {
1397             n = *(U8*)start;
1398             skip = 1;
1399         }
1400         retval += ((NV)n)/nshift;
1401         start += skip;
1402         nshift *= 1000;
1403     }
1404     return retval;
1405 }
1406
1407 /*
1408  * S_force_version
1409  * Forces the next token to be a version number.
1410  * If the next token appears to be an invalid version number, (e.g. "v2b"),
1411  * and if "guessing" is TRUE, then no new token is created (and the caller
1412  * must use an alternative parsing method).
1413  */
1414
1415 STATIC char *
1416 S_force_version(pTHX_ char *s, int guessing)
1417 {
1418     dVAR;
1419     OP *version = NULL;
1420     char *d;
1421 #ifdef PERL_MAD
1422     I32 startoff = s - SvPVX(PL_linestr);
1423 #endif
1424
1425     s = SKIPSPACE1(s);
1426
1427     d = s;
1428     if (*d == 'v')
1429         d++;
1430     if (isDIGIT(*d)) {
1431         while (isDIGIT(*d) || *d == '_' || *d == '.')
1432             d++;
1433 #ifdef PERL_MAD
1434         if (PL_madskills) {
1435             start_force(PL_curforce);
1436             curmad('X', newSVpvn(s,d-s));
1437         }
1438 #endif
1439         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
1440             SV *ver;
1441             s = scan_num(s, &yylval);
1442             version = yylval.opval;
1443             ver = cSVOPx(version)->op_sv;
1444             if (SvPOK(ver) && !SvNIOK(ver)) {
1445                 SvUPGRADE(ver, SVt_PVNV);
1446                 SvNV_set(ver, str_to_version(ver));
1447                 SvNOK_on(ver);          /* hint that it is a version */
1448             }
1449         }
1450         else if (guessing) {
1451 #ifdef PERL_MAD
1452             if (PL_madskills) {
1453                 sv_free(PL_nextwhite);  /* let next token collect whitespace */
1454                 PL_nextwhite = 0;
1455                 s = SvPVX(PL_linestr) + startoff;
1456             }
1457 #endif
1458             return s;
1459         }
1460     }
1461
1462 #ifdef PERL_MAD
1463     if (PL_madskills && !version) {
1464         sv_free(PL_nextwhite);  /* let next token collect whitespace */
1465         PL_nextwhite = 0;
1466         s = SvPVX(PL_linestr) + startoff;
1467     }
1468 #endif
1469     /* NOTE: The parser sees the package name and the VERSION swapped */
1470     start_force(PL_curforce);
1471     NEXTVAL_NEXTTOKE.opval = version;
1472     force_next(WORD);
1473
1474     return s;
1475 }
1476
1477 /*
1478  * S_tokeq
1479  * Tokenize a quoted string passed in as an SV.  It finds the next
1480  * chunk, up to end of string or a backslash.  It may make a new
1481  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
1482  * turns \\ into \.
1483  */
1484
1485 STATIC SV *
1486 S_tokeq(pTHX_ SV *sv)
1487 {
1488     dVAR;
1489     register char *s;
1490     register char *send;
1491     register char *d;
1492     STRLEN len = 0;
1493     SV *pv = sv;
1494
1495     if (!SvLEN(sv))
1496         goto finish;
1497
1498     s = SvPV_force(sv, len);
1499     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
1500         goto finish;
1501     send = s + len;
1502     while (s < send && *s != '\\')
1503         s++;
1504     if (s == send)
1505         goto finish;
1506     d = s;
1507     if ( PL_hints & HINT_NEW_STRING ) {
1508         pv = sv_2mortal(newSVpvn(SvPVX_const(pv), len));
1509         if (SvUTF8(sv))
1510             SvUTF8_on(pv);
1511     }
1512     while (s < send) {
1513         if (*s == '\\') {
1514             if (s + 1 < send && (s[1] == '\\'))
1515                 s++;            /* all that, just for this */
1516         }
1517         *d++ = *s++;
1518     }
1519     *d = '\0';
1520     SvCUR_set(sv, d - SvPVX_const(sv));
1521   finish:
1522     if ( PL_hints & HINT_NEW_STRING )
1523        return new_constant(NULL, 0, "q", sv, pv, "q");
1524     return sv;
1525 }
1526
1527 /*
1528  * Now come three functions related to double-quote context,
1529  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
1530  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
1531  * interact with PL_lex_state, and create fake ( ... ) argument lists
1532  * to handle functions and concatenation.
1533  * They assume that whoever calls them will be setting up a fake
1534  * join call, because each subthing puts a ',' after it.  This lets
1535  *   "lower \luPpEr"
1536  * become
1537  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
1538  *
1539  * (I'm not sure whether the spurious commas at the end of lcfirst's
1540  * arguments and join's arguments are created or not).
1541  */
1542
1543 /*
1544  * S_sublex_start
1545  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
1546  *
1547  * Pattern matching will set PL_lex_op to the pattern-matching op to
1548  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
1549  *
1550  * OP_CONST and OP_READLINE are easy--just make the new op and return.
1551  *
1552  * Everything else becomes a FUNC.
1553  *
1554  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
1555  * had an OP_CONST or OP_READLINE).  This just sets us up for a
1556  * call to S_sublex_push().
1557  */
1558
1559 STATIC I32
1560 S_sublex_start(pTHX)
1561 {
1562     dVAR;
1563     register const I32 op_type = yylval.ival;
1564
1565     if (op_type == OP_NULL) {
1566         yylval.opval = PL_lex_op;
1567         PL_lex_op = NULL;
1568         return THING;
1569     }
1570     if (op_type == OP_CONST || op_type == OP_READLINE) {
1571         SV *sv = tokeq(PL_lex_stuff);
1572
1573         if (SvTYPE(sv) == SVt_PVIV) {
1574             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
1575             STRLEN len;
1576             const char * const p = SvPV_const(sv, len);
1577             SV * const nsv = newSVpvn(p, len);
1578             if (SvUTF8(sv))
1579                 SvUTF8_on(nsv);
1580             SvREFCNT_dec(sv);
1581             sv = nsv;
1582         }
1583         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1584         PL_lex_stuff = NULL;
1585         /* Allow <FH> // "foo" */
1586         if (op_type == OP_READLINE)
1587             PL_expect = XTERMORDORDOR;
1588         return THING;
1589     }
1590     else if (op_type == OP_BACKTICK && PL_lex_op) {
1591         /* readpipe() vas overriden */
1592         cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff);
1593         yylval.opval = PL_lex_op;
1594         PL_lex_op = NULL;
1595         PL_lex_stuff = NULL;
1596         return THING;
1597     }
1598
1599     PL_sublex_info.super_state = PL_lex_state;
1600     PL_sublex_info.sub_inwhat = op_type;
1601     PL_sublex_info.sub_op = PL_lex_op;
1602     PL_lex_state = LEX_INTERPPUSH;
1603
1604     PL_expect = XTERM;
1605     if (PL_lex_op) {
1606         yylval.opval = PL_lex_op;
1607         PL_lex_op = NULL;
1608         return PMFUNC;
1609     }
1610     else
1611         return FUNC;
1612 }
1613
1614 /*
1615  * S_sublex_push
1616  * Create a new scope to save the lexing state.  The scope will be
1617  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1618  * to the uc, lc, etc. found before.
1619  * Sets PL_lex_state to LEX_INTERPCONCAT.
1620  */
1621
1622 STATIC I32
1623 S_sublex_push(pTHX)
1624 {
1625     dVAR;
1626     ENTER;
1627
1628     PL_lex_state = PL_sublex_info.super_state;
1629     SAVEI32(PL_lex_dojoin);
1630     SAVEI32(PL_lex_brackets);
1631     SAVEI32(PL_lex_casemods);
1632     SAVEI32(PL_lex_starts);
1633     SAVEI32(PL_lex_state);
1634     SAVEVPTR(PL_lex_inpat);
1635     SAVEI32(PL_lex_inwhat);
1636     SAVECOPLINE(PL_curcop);
1637     SAVEPPTR(PL_bufptr);
1638     SAVEPPTR(PL_bufend);
1639     SAVEPPTR(PL_oldbufptr);
1640     SAVEPPTR(PL_oldoldbufptr);
1641     SAVEPPTR(PL_last_lop);
1642     SAVEPPTR(PL_last_uni);
1643     SAVEPPTR(PL_linestart);
1644     SAVESPTR(PL_linestr);
1645     SAVEGENERICPV(PL_lex_brackstack);
1646     SAVEGENERICPV(PL_lex_casestack);
1647
1648     PL_linestr = PL_lex_stuff;
1649     PL_lex_stuff = NULL;
1650
1651     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1652         = SvPVX(PL_linestr);
1653     PL_bufend += SvCUR(PL_linestr);
1654     PL_last_lop = PL_last_uni = NULL;
1655     SAVEFREESV(PL_linestr);
1656
1657     PL_lex_dojoin = FALSE;
1658     PL_lex_brackets = 0;
1659     Newx(PL_lex_brackstack, 120, char);
1660     Newx(PL_lex_casestack, 12, char);
1661     PL_lex_casemods = 0;
1662     *PL_lex_casestack = '\0';
1663     PL_lex_starts = 0;
1664     PL_lex_state = LEX_INTERPCONCAT;
1665     CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1666
1667     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1668     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1669         PL_lex_inpat = PL_sublex_info.sub_op;
1670     else
1671         PL_lex_inpat = NULL;
1672
1673     return '(';
1674 }
1675
1676 /*
1677  * S_sublex_done
1678  * Restores lexer state after a S_sublex_push.
1679  */
1680
1681 STATIC I32
1682 S_sublex_done(pTHX)
1683 {
1684     dVAR;
1685     if (!PL_lex_starts++) {
1686         SV * const sv = newSVpvs("");
1687         if (SvUTF8(PL_linestr))
1688             SvUTF8_on(sv);
1689         PL_expect = XOPERATOR;
1690         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1691         return THING;
1692     }
1693
1694     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1695         PL_lex_state = LEX_INTERPCASEMOD;
1696         return yylex();
1697     }
1698
1699     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1700     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1701         PL_linestr = PL_lex_repl;
1702         PL_lex_inpat = 0;
1703         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1704         PL_bufend += SvCUR(PL_linestr);
1705         PL_last_lop = PL_last_uni = NULL;
1706         SAVEFREESV(PL_linestr);
1707         PL_lex_dojoin = FALSE;
1708         PL_lex_brackets = 0;
1709         PL_lex_casemods = 0;
1710         *PL_lex_casestack = '\0';
1711         PL_lex_starts = 0;
1712         if (SvEVALED(PL_lex_repl)) {
1713             PL_lex_state = LEX_INTERPNORMAL;
1714             PL_lex_starts++;
1715             /*  we don't clear PL_lex_repl here, so that we can check later
1716                 whether this is an evalled subst; that means we rely on the
1717                 logic to ensure sublex_done() is called again only via the
1718                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1719         }
1720         else {
1721             PL_lex_state = LEX_INTERPCONCAT;
1722             PL_lex_repl = NULL;
1723         }
1724         return ',';
1725     }
1726     else {
1727 #ifdef PERL_MAD
1728         if (PL_madskills) {
1729             if (PL_thiswhite) {
1730                 if (!PL_endwhite)
1731                     PL_endwhite = newSVpvs("");
1732                 sv_catsv(PL_endwhite, PL_thiswhite);
1733                 PL_thiswhite = 0;
1734             }
1735             if (PL_thistoken)
1736                 sv_setpvn(PL_thistoken,"",0);
1737             else
1738                 PL_realtokenstart = -1;
1739         }
1740 #endif
1741         LEAVE;
1742         PL_bufend = SvPVX(PL_linestr);
1743         PL_bufend += SvCUR(PL_linestr);
1744         PL_expect = XOPERATOR;
1745         PL_sublex_info.sub_inwhat = 0;
1746         return ')';
1747     }
1748 }
1749
1750 /*
1751   scan_const
1752
1753   Extracts a pattern, double-quoted string, or transliteration.  This
1754   is terrifying code.
1755
1756   It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's
1757   processing a pattern (PL_lex_inpat is true), a transliteration
1758   (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string.
1759
1760   Returns a pointer to the character scanned up to. If this is
1761   advanced from the start pointer supplied (i.e. if anything was
1762   successfully parsed), will leave an OP for the substring scanned
1763   in yylval. Caller must intuit reason for not parsing further
1764   by looking at the next characters herself.
1765
1766   In patterns:
1767     backslashes:
1768       double-quoted style: \r and \n
1769       regexp special ones: \D \s
1770       constants: \x31
1771       backrefs: \1
1772       case and quoting: \U \Q \E
1773     stops on @ and $, but not for $ as tail anchor
1774
1775   In transliterations:
1776     characters are VERY literal, except for - not at the start or end
1777     of the string, which indicates a range. If the range is in bytes,
1778     scan_const expands the range to the full set of intermediate
1779     characters. If the range is in utf8, the hyphen is replaced with
1780     a certain range mark which will be handled by pmtrans() in op.c.
1781
1782   In double-quoted strings:
1783     backslashes:
1784       double-quoted style: \r and \n
1785       constants: \x31
1786       deprecated backrefs: \1 (in substitution replacements)
1787       case and quoting: \U \Q \E
1788     stops on @ and $
1789
1790   scan_const does *not* construct ops to handle interpolated strings.
1791   It stops processing as soon as it finds an embedded $ or @ variable
1792   and leaves it to the caller to work out what's going on.
1793
1794   embedded arrays (whether in pattern or not) could be:
1795       @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-.
1796
1797   $ in double-quoted strings must be the symbol of an embedded scalar.
1798
1799   $ in pattern could be $foo or could be tail anchor.  Assumption:
1800   it's a tail anchor if $ is the last thing in the string, or if it's
1801   followed by one of "()| \r\n\t"
1802
1803   \1 (backreferences) are turned into $1
1804
1805   The structure of the code is
1806       while (there's a character to process) {
1807           handle transliteration ranges
1808           skip regexp comments /(?#comment)/ and codes /(?{code})/
1809           skip #-initiated comments in //x patterns
1810           check for embedded arrays
1811           check for embedded scalars
1812           if (backslash) {
1813               leave intact backslashes from leaveit (below)
1814               deprecate \1 in substitution replacements
1815               handle string-changing backslashes \l \U \Q \E, etc.
1816               switch (what was escaped) {
1817                   handle \- in a transliteration (becomes a literal -)
1818                   handle \132 (octal characters)
1819                   handle \x15 and \x{1234} (hex characters)
1820                   handle \N{name} (named characters)
1821                   handle \cV (control characters)
1822                   handle printf-style backslashes (\f, \r, \n, etc)
1823               } (end switch)
1824           } (end if backslash)
1825     } (end while character to read)
1826
1827 */
1828
1829 STATIC char *
1830 S_scan_const(pTHX_ char *start)
1831 {
1832     dVAR;
1833     register char *send = PL_bufend;            /* end of the constant */
1834     SV *sv = newSV(send - start);               /* sv for the constant */
1835     register char *s = start;                   /* start of the constant */
1836     register char *d = SvPVX(sv);               /* destination for copies */
1837     bool dorange = FALSE;                       /* are we in a translit range? */
1838     bool didrange = FALSE;                      /* did we just finish a range? */
1839     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1840     I32  this_utf8 = UTF;                       /* The source string is assumed to be UTF8 */
1841     UV uv;
1842 #ifdef EBCDIC
1843     UV literal_endpoint = 0;
1844     bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */
1845 #endif
1846
1847     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1848         /* If we are doing a trans and we know we want UTF8 set expectation */
1849         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1850         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1851     }
1852
1853
1854     while (s < send || dorange) {
1855         /* get transliterations out of the way (they're most literal) */
1856         if (PL_lex_inwhat == OP_TRANS) {
1857             /* expand a range A-Z to the full set of characters.  AIE! */
1858             if (dorange) {
1859                 I32 i;                          /* current expanded character */
1860                 I32 min;                        /* first character in range */
1861                 I32 max;                        /* last character in range */
1862
1863 #ifdef EBCDIC
1864                 UV uvmax = 0;
1865 #endif
1866
1867                 if (has_utf8
1868 #ifdef EBCDIC
1869                     && !native_range
1870 #endif
1871                     ) {
1872                     char * const c = (char*)utf8_hop((U8*)d, -1);
1873                     char *e = d++;
1874                     while (e-- > c)
1875                         *(e + 1) = *e;
1876                     *c = (char)UTF_TO_NATIVE(0xff);
1877                     /* mark the range as done, and continue */
1878                     dorange = FALSE;
1879                     didrange = TRUE;
1880                     continue;
1881                 }
1882
1883                 i = d - SvPVX_const(sv);                /* remember current offset */
1884 #ifdef EBCDIC
1885                 SvGROW(sv,
1886                        SvLEN(sv) + (has_utf8 ?
1887                                     (512 - UTF_CONTINUATION_MARK +
1888                                      UNISKIP(0x100))
1889                                     : 256));
1890                 /* How many two-byte within 0..255: 128 in UTF-8,
1891                  * 96 in UTF-8-mod. */
1892 #else
1893                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1894 #endif
1895                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1896 #ifdef EBCDIC
1897                 if (has_utf8) {
1898                     int j;
1899                     for (j = 0; j <= 1; j++) {
1900                         char * const c = (char*)utf8_hop((U8*)d, -1);
1901                         const UV uv    = utf8n_to_uvchr((U8*)c, d - c, NULL, 0);
1902                         if (j)
1903                             min = (U8)uv;
1904                         else if (uv < 256)
1905                             max = (U8)uv;
1906                         else {
1907                             max = (U8)0xff; /* only to \xff */
1908                             uvmax = uv; /* \x{100} to uvmax */
1909                         }
1910                         d = c; /* eat endpoint chars */
1911                      }
1912                 }
1913                else {
1914 #endif
1915                    d -= 2;              /* eat the first char and the - */
1916                    min = (U8)*d;        /* first char in range */
1917                    max = (U8)d[1];      /* last char in range  */
1918 #ifdef EBCDIC
1919                }
1920 #endif
1921
1922                 if (min > max) {
1923                     Perl_croak(aTHX_
1924                                "Invalid range \"%c-%c\" in transliteration operator",
1925                                (char)min, (char)max);
1926                 }
1927
1928 #ifdef EBCDIC
1929                 if (literal_endpoint == 2 &&
1930                     ((isLOWER(min) && isLOWER(max)) ||
1931                      (isUPPER(min) && isUPPER(max)))) {
1932                     if (isLOWER(min)) {
1933                         for (i = min; i <= max; i++)
1934                             if (isLOWER(i))
1935                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1936                     } else {
1937                         for (i = min; i <= max; i++)
1938                             if (isUPPER(i))
1939                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1940                     }
1941                 }
1942                 else
1943 #endif
1944                     for (i = min; i <= max; i++)
1945 #ifdef EBCDIC
1946                         if (has_utf8) {
1947                             const U8 ch = (U8)NATIVE_TO_UTF(i);
1948                             if (UNI_IS_INVARIANT(ch))
1949                                 *d++ = (U8)i;
1950                             else {
1951                                 *d++ = (U8)UTF8_EIGHT_BIT_HI(ch);
1952                                 *d++ = (U8)UTF8_EIGHT_BIT_LO(ch);
1953                             }
1954                         }
1955                         else
1956 #endif
1957                             *d++ = (char)i;
1958
1959 #ifdef EBCDIC
1960                 if (uvmax) {
1961                     d = (char*)uvchr_to_utf8((U8*)d, 0x100);
1962                     if (uvmax > 0x101)
1963                         *d++ = (char)UTF_TO_NATIVE(0xff);
1964                     if (uvmax > 0x100)
1965                         d = (char*)uvchr_to_utf8((U8*)d, uvmax);
1966                 }
1967 #endif
1968
1969                 /* mark the range as done, and continue */
1970                 dorange = FALSE;
1971                 didrange = TRUE;
1972 #ifdef EBCDIC
1973                 literal_endpoint = 0;
1974 #endif
1975                 continue;
1976             }
1977
1978             /* range begins (ignore - as first or last char) */
1979             else if (*s == '-' && s+1 < send  && s != start) {
1980                 if (didrange) {
1981                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1982                 }
1983                 if (has_utf8
1984 #ifdef EBCDIC
1985                     && !native_range
1986 #endif
1987                     ) {
1988                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
1989                     s++;
1990                     continue;
1991                 }
1992                 dorange = TRUE;
1993                 s++;
1994             }
1995             else {
1996                 didrange = FALSE;
1997 #ifdef EBCDIC
1998                 literal_endpoint = 0;
1999                 native_range = TRUE;
2000 #endif
2001             }
2002         }
2003
2004         /* if we get here, we're not doing a transliteration */
2005
2006         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
2007            except for the last char, which will be done separately. */
2008         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
2009             if (s[2] == '#') {
2010                 while (s+1 < send && *s != ')')
2011                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2012             }
2013             else if (s[2] == '{' /* This should match regcomp.c */
2014                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
2015             {
2016                 I32 count = 1;
2017                 char *regparse = s + (s[2] == '{' ? 3 : 4);
2018                 char c;
2019
2020                 while (count && (c = *regparse)) {
2021                     if (c == '\\' && regparse[1])
2022                         regparse++;
2023                     else if (c == '{')
2024                         count++;
2025                     else if (c == '}')
2026                         count--;
2027                     regparse++;
2028                 }
2029                 if (*regparse != ')')
2030                     regparse--;         /* Leave one char for continuation. */
2031                 while (s < regparse)
2032                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2033             }
2034         }
2035
2036         /* likewise skip #-initiated comments in //x patterns */
2037         else if (*s == '#' && PL_lex_inpat &&
2038           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
2039             while (s+1 < send && *s != '\n')
2040                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2041         }
2042
2043         /* check for embedded arrays
2044            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
2045            */
2046         else if (*s == '@' && s[1]) {
2047             if (isALNUM_lazy_if(s+1,UTF))
2048                 break;
2049             if (strchr(":'{$", s[1]))
2050                 break;
2051             if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-'))
2052                 break; /* in regexp, neither @+ nor @- are interpolated */
2053         }
2054
2055         /* check for embedded scalars.  only stop if we're sure it's a
2056            variable.
2057         */
2058         else if (*s == '$') {
2059             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
2060                 break;
2061             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
2062                 break;          /* in regexp, $ might be tail anchor */
2063         }
2064
2065         /* End of else if chain - OP_TRANS rejoin rest */
2066
2067         /* backslashes */
2068         if (*s == '\\' && s+1 < send) {
2069             s++;
2070
2071             /* deprecate \1 in strings and substitution replacements */
2072             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
2073                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
2074             {
2075                 if (ckWARN(WARN_SYNTAX))
2076                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
2077                 *--s = '$';
2078                 break;
2079             }
2080
2081             /* string-change backslash escapes */
2082             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
2083                 --s;
2084                 break;
2085             }
2086             /* skip any other backslash escapes in a pattern */
2087             else if (PL_lex_inpat) {
2088                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
2089                 goto default_action;
2090             }
2091
2092             /* if we get here, it's either a quoted -, or a digit */
2093             switch (*s) {
2094
2095             /* quoted - in transliterations */
2096             case '-':
2097                 if (PL_lex_inwhat == OP_TRANS) {
2098                     *d++ = *s++;
2099                     continue;
2100                 }
2101                 /* FALL THROUGH */
2102             default:
2103                 {
2104                     if ((isALPHA(*s) || isDIGIT(*s)) &&
2105                         ckWARN(WARN_MISC))
2106                         Perl_warner(aTHX_ packWARN(WARN_MISC),
2107                                     "Unrecognized escape \\%c passed through",
2108                                     *s);
2109                     /* default action is to copy the quoted character */
2110                     goto default_action;
2111                 }
2112
2113             /* \132 indicates an octal constant */
2114             case '0': case '1': case '2': case '3':
2115             case '4': case '5': case '6': case '7':
2116                 {
2117                     I32 flags = 0;
2118                     STRLEN len = 3;
2119                     uv = grok_oct(s, &len, &flags, NULL);
2120                     s += len;
2121                 }
2122                 goto NUM_ESCAPE_INSERT;
2123
2124             /* \x24 indicates a hex constant */
2125             case 'x':
2126                 ++s;
2127                 if (*s == '{') {
2128                     char* const e = strchr(s, '}');
2129                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2130                       PERL_SCAN_DISALLOW_PREFIX;
2131                     STRLEN len;
2132
2133                     ++s;
2134                     if (!e) {
2135                         yyerror("Missing right brace on \\x{}");
2136                         continue;
2137                     }
2138                     len = e - s;
2139                     uv = grok_hex(s, &len, &flags, NULL);
2140                     s = e + 1;
2141                 }
2142                 else {
2143                     {
2144                         STRLEN len = 2;
2145                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
2146                         uv = grok_hex(s, &len, &flags, NULL);
2147                         s += len;
2148                     }
2149                 }
2150
2151               NUM_ESCAPE_INSERT:
2152                 /* Insert oct or hex escaped character.
2153                  * There will always enough room in sv since such
2154                  * escapes will be longer than any UTF-8 sequence
2155                  * they can end up as. */
2156
2157                 /* We need to map to chars to ASCII before doing the tests
2158                    to cover EBCDIC
2159                 */
2160                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
2161                     if (!has_utf8 && uv > 255) {
2162                         /* Might need to recode whatever we have
2163                          * accumulated so far if it contains any
2164                          * hibit chars.
2165                          *
2166                          * (Can't we keep track of that and avoid
2167                          *  this rescan? --jhi)
2168                          */
2169                         int hicount = 0;
2170                         U8 *c;
2171                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
2172                             if (!NATIVE_IS_INVARIANT(*c)) {
2173                                 hicount++;
2174                             }
2175                         }
2176                         if (hicount) {
2177                             const STRLEN offset = d - SvPVX_const(sv);
2178                             U8 *src, *dst;
2179                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
2180                             src = (U8 *)d - 1;
2181                             dst = src+hicount;
2182                             d  += hicount;
2183                             while (src >= (const U8 *)SvPVX_const(sv)) {
2184                                 if (!NATIVE_IS_INVARIANT(*src)) {
2185                                     const U8 ch = NATIVE_TO_ASCII(*src);
2186                                     *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
2187                                     *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
2188                                 }
2189                                 else {
2190                                     *dst-- = *src;
2191                                 }
2192                                 src--;
2193                             }
2194                         }
2195                     }
2196
2197                     if (has_utf8 || uv > 255) {
2198                         d = (char*)uvchr_to_utf8((U8*)d, uv);
2199                         has_utf8 = TRUE;
2200                         if (PL_lex_inwhat == OP_TRANS &&
2201                             PL_sublex_info.sub_op) {
2202                             PL_sublex_info.sub_op->op_private |=
2203                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
2204                                              : OPpTRANS_TO_UTF);
2205                         }
2206 #ifdef EBCDIC
2207                         if (uv > 255 && !dorange)
2208                             native_range = FALSE;
2209 #endif
2210                     }
2211                     else {
2212                         *d++ = (char)uv;
2213                     }
2214                 }
2215                 else {
2216                     *d++ = (char) uv;
2217                 }
2218                 continue;
2219
2220             /* \N{LATIN SMALL LETTER A} is a named character */
2221             case 'N':
2222                 ++s;
2223                 if (*s == '{') {
2224                     char* e = strchr(s, '}');
2225                     SV *res;
2226                     STRLEN len;
2227                     const char *str;
2228                     SV *type;
2229
2230                     if (!e) {
2231                         yyerror("Missing right brace on \\N{}");
2232                         e = s - 1;
2233                         goto cont_scan;
2234                     }
2235                     if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
2236                         /* \N{U+...} */
2237                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
2238                           PERL_SCAN_DISALLOW_PREFIX;
2239                         s += 3;
2240                         len = e - s;
2241                         uv = grok_hex(s, &len, &flags, NULL);
2242                         if ( e > s && len != (STRLEN)(e - s) ) {
2243                             uv = 0xFFFD;
2244                         }
2245                         s = e + 1;
2246                         goto NUM_ESCAPE_INSERT;
2247                     }
2248                     res = newSVpvn(s + 1, e - s - 1);
2249                     type = newSVpvn(s - 2,e - s + 3);
2250                     res = new_constant( NULL, 0, "charnames",
2251                                         res, NULL, SvPVX(type) );
2252                     SvREFCNT_dec(type);
2253                     if (has_utf8)
2254                         sv_utf8_upgrade(res);
2255                     str = SvPV_const(res,len);
2256 #ifdef EBCDIC_NEVER_MIND
2257                     /* charnames uses pack U and that has been
2258                      * recently changed to do the below uni->native
2259                      * mapping, so this would be redundant (and wrong,
2260                      * the code point would be doubly converted).
2261                      * But leave this in just in case the pack U change
2262                      * gets revoked, but the semantics is still
2263                      * desireable for charnames. --jhi */
2264                     {
2265                          UV uv = utf8_to_uvchr((const U8*)str, 0);
2266
2267                          if (uv < 0x100) {
2268                               U8 tmpbuf[UTF8_MAXBYTES+1], *d;
2269
2270                               d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
2271                               sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
2272                               str = SvPV_const(res, len);
2273                          }
2274                     }
2275 #endif
2276                     if (!has_utf8 && SvUTF8(res)) {
2277                         const char * const ostart = SvPVX_const(sv);
2278                         SvCUR_set(sv, d - ostart);
2279                         SvPOK_on(sv);
2280                         *d = '\0';
2281                         sv_utf8_upgrade(sv);
2282                         /* this just broke our allocation above... */
2283                         SvGROW(sv, (STRLEN)(send - start));
2284                         d = SvPVX(sv) + SvCUR(sv);
2285                         has_utf8 = TRUE;
2286                     }
2287                     if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
2288                         const char * const odest = SvPVX_const(sv);
2289
2290                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
2291                         d = SvPVX(sv) + (d - odest);
2292                     }
2293 #ifdef EBCDIC
2294                     if (!dorange)
2295                         native_range = FALSE; /* \N{} is guessed to be Unicode */
2296 #endif
2297                     Copy(str, d, len, char);
2298                     d += len;
2299                     SvREFCNT_dec(res);
2300                   cont_scan:
2301                     s = e + 1;
2302                 }
2303                 else
2304                     yyerror("Missing braces on \\N{}");
2305                 continue;
2306
2307             /* \c is a control character */
2308             case 'c':
2309                 s++;
2310                 if (s < send) {
2311                     U8 c = *s++;
2312 #ifdef EBCDIC
2313                     if (isLOWER(c))
2314                         c = toUPPER(c);
2315 #endif
2316                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
2317                 }
2318                 else {
2319                     yyerror("Missing control char name in \\c");
2320                 }
2321                 continue;
2322
2323             /* printf-style backslashes, formfeeds, newlines, etc */
2324             case 'b':
2325                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
2326                 break;
2327             case 'n':
2328                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
2329                 break;
2330             case 'r':
2331                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
2332                 break;
2333             case 'f':
2334                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
2335                 break;
2336             case 't':
2337                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
2338                 break;
2339             case 'e':
2340                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
2341                 break;
2342             case 'a':
2343                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
2344                 break;
2345             } /* end switch */
2346
2347             s++;
2348             continue;
2349         } /* end if (backslash) */
2350 #ifdef EBCDIC
2351         else
2352             literal_endpoint++;
2353 #endif
2354
2355     default_action:
2356         /* If we started with encoded form, or already know we want it
2357            and then encode the next character */
2358         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
2359             STRLEN len  = 1;
2360             const UV nextuv   = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
2361             const STRLEN need = UNISKIP(NATIVE_TO_UNI(nextuv));
2362             s += len;
2363             if (need > len) {
2364                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
2365                 const STRLEN off = d - SvPVX_const(sv);
2366                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
2367             }
2368             d = (char*)uvchr_to_utf8((U8*)d, nextuv);
2369             has_utf8 = TRUE;
2370 #ifdef EBCDIC
2371             if (uv > 255 && !dorange)
2372                 native_range = FALSE;
2373 #endif
2374         }
2375         else {
2376             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
2377         }
2378     } /* while loop to process each character */
2379
2380     /* terminate the string and set up the sv */
2381     *d = '\0';
2382     SvCUR_set(sv, d - SvPVX_const(sv));
2383     if (SvCUR(sv) >= SvLEN(sv))
2384         Perl_croak(aTHX_ "panic: constant overflowed allocated space");
2385
2386     SvPOK_on(sv);
2387     if (PL_encoding && !has_utf8) {
2388         sv_recode_to_utf8(sv, PL_encoding);
2389         if (SvUTF8(sv))
2390             has_utf8 = TRUE;
2391     }
2392     if (has_utf8) {
2393         SvUTF8_on(sv);
2394         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
2395             PL_sublex_info.sub_op->op_private |=
2396                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
2397         }
2398     }
2399
2400     /* shrink the sv if we allocated more than we used */
2401     if (SvCUR(sv) + 5 < SvLEN(sv)) {
2402         SvPV_shrink_to_cur(sv);
2403     }
2404
2405     /* return the substring (via yylval) only if we parsed anything */
2406     if (s > PL_bufptr) {
2407         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
2408             sv = new_constant(start, s - start,
2409                               (const char *)(PL_lex_inpat ? "qr" : "q"),
2410                               sv, NULL,
2411                               (const char *)
2412                               (( PL_lex_inwhat == OP_TRANS
2413                                  ? "tr"
2414                                  : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
2415                                      ? "s"
2416                                      : "qq"))));
2417         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2418     } else
2419         SvREFCNT_dec(sv);
2420     return s;
2421 }
2422
2423 /* S_intuit_more
2424  * Returns TRUE if there's more to the expression (e.g., a subscript),
2425  * FALSE otherwise.
2426  *
2427  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
2428  *
2429  * ->[ and ->{ return TRUE
2430  * { and [ outside a pattern are always subscripts, so return TRUE
2431  * if we're outside a pattern and it's not { or [, then return FALSE
2432  * if we're in a pattern and the first char is a {
2433  *   {4,5} (any digits around the comma) returns FALSE
2434  * if we're in a pattern and the first char is a [
2435  *   [] returns FALSE
2436  *   [SOMETHING] has a funky algorithm to decide whether it's a
2437  *      character class or not.  It has to deal with things like
2438  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
2439  * anything else returns TRUE
2440  */
2441
2442 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
2443
2444 STATIC int
2445 S_intuit_more(pTHX_ register char *s)
2446 {
2447     dVAR;
2448     if (PL_lex_brackets)
2449         return TRUE;
2450     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
2451         return TRUE;
2452     if (*s != '{' && *s != '[')
2453         return FALSE;
2454     if (!PL_lex_inpat)
2455         return TRUE;
2456
2457     /* In a pattern, so maybe we have {n,m}. */
2458     if (*s == '{') {
2459         s++;
2460         if (!isDIGIT(*s))
2461             return TRUE;
2462         while (isDIGIT(*s))
2463             s++;
2464         if (*s == ',')
2465             s++;
2466         while (isDIGIT(*s))
2467             s++;
2468         if (*s == '}')
2469             return FALSE;
2470         return TRUE;
2471
2472     }
2473
2474     /* On the other hand, maybe we have a character class */
2475
2476     s++;
2477     if (*s == ']' || *s == '^')
2478         return FALSE;
2479     else {
2480         /* this is terrifying, and it works */
2481         int weight = 2;         /* let's weigh the evidence */
2482         char seen[256];
2483         unsigned char un_char = 255, last_un_char;
2484         const char * const send = strchr(s,']');
2485         char tmpbuf[sizeof PL_tokenbuf * 4];
2486
2487         if (!send)              /* has to be an expression */
2488             return TRUE;
2489
2490         Zero(seen,256,char);
2491         if (*s == '$')
2492             weight -= 3;
2493         else if (isDIGIT(*s)) {
2494             if (s[1] != ']') {
2495                 if (isDIGIT(s[1]) && s[2] == ']')
2496                     weight -= 10;
2497             }
2498             else
2499                 weight -= 100;
2500         }
2501         for (; s < send; s++) {
2502             last_un_char = un_char;
2503             un_char = (unsigned char)*s;
2504             switch (*s) {
2505             case '@':
2506             case '&':
2507             case '$':
2508                 weight -= seen[un_char] * 10;
2509                 if (isALNUM_lazy_if(s+1,UTF)) {
2510                     int len;
2511                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
2512                     len = (int)strlen(tmpbuf);
2513                     if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PV))
2514                         weight -= 100;
2515                     else
2516                         weight -= 10;
2517                 }
2518                 else if (*s == '$' && s[1] &&
2519                   strchr("[#!%*<>()-=",s[1])) {
2520                     if (/*{*/ strchr("])} =",s[2]))
2521                         weight -= 10;
2522                     else
2523                         weight -= 1;
2524                 }
2525                 break;
2526             case '\\':
2527                 un_char = 254;
2528                 if (s[1]) {
2529                     if (strchr("wds]",s[1]))
2530                         weight += 100;
2531                     else if (seen[(U8)'\''] || seen[(U8)'"'])
2532                         weight += 1;
2533                     else if (strchr("rnftbxcav",s[1]))
2534                         weight += 40;
2535                     else if (isDIGIT(s[1])) {
2536                         weight += 40;
2537                         while (s[1] && isDIGIT(s[1]))
2538                             s++;
2539                     }
2540                 }
2541                 else
2542                     weight += 100;
2543                 break;
2544             case '-':
2545                 if (s[1] == '\\')
2546                     weight += 50;
2547                 if (strchr("aA01! ",last_un_char))
2548                     weight += 30;
2549                 if (strchr("zZ79~",s[1]))
2550                     weight += 30;
2551                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
2552                     weight -= 5;        /* cope with negative subscript */
2553                 break;
2554             default:
2555                 if (!isALNUM(last_un_char)
2556                     && !(last_un_char == '$' || last_un_char == '@'
2557                          || last_un_char == '&')
2558                     && isALPHA(*s) && s[1] && isALPHA(s[1])) {
2559                     char *d = tmpbuf;
2560                     while (isALPHA(*s))
2561                         *d++ = *s++;
2562                     *d = '\0';
2563                     if (keyword(tmpbuf, d - tmpbuf, 0))
2564                         weight -= 150;
2565                 }
2566                 if (un_char == last_un_char + 1)
2567                     weight += 5;
2568                 weight -= seen[un_char];
2569                 break;
2570             }
2571             seen[un_char]++;
2572         }
2573         if (weight >= 0)        /* probably a character class */
2574             return FALSE;
2575     }
2576
2577     return TRUE;
2578 }
2579
2580 /*
2581  * S_intuit_method
2582  *
2583  * Does all the checking to disambiguate
2584  *   foo bar
2585  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
2586  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
2587  *
2588  * First argument is the stuff after the first token, e.g. "bar".
2589  *
2590  * Not a method if bar is a filehandle.
2591  * Not a method if foo is a subroutine prototyped to take a filehandle.
2592  * Not a method if it's really "Foo $bar"
2593  * Method if it's "foo $bar"
2594  * Not a method if it's really "print foo $bar"
2595  * Method if it's really "foo package::" (interpreted as package->foo)
2596  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
2597  * Not a method if bar is a filehandle or package, but is quoted with
2598  *   =>
2599  */
2600
2601 STATIC int
2602 S_intuit_method(pTHX_ char *start, GV *gv, CV *cv)
2603 {
2604     dVAR;
2605     char *s = start + (*start == '$');
2606     char tmpbuf[sizeof PL_tokenbuf];
2607     STRLEN len;
2608     GV* indirgv;
2609 #ifdef PERL_MAD
2610     int soff;
2611 #endif
2612
2613     if (gv) {
2614         if (SvTYPE(gv) == SVt_PVGV && GvIO(gv))
2615             return 0;
2616         if (cv) {
2617             if (SvPOK(cv)) {
2618                 const char *proto = SvPVX_const(cv);
2619                 if (proto) {
2620                     if (*proto == ';')
2621                         proto++;
2622                     if (*proto == '*')
2623                         return 0;
2624                 }
2625             }
2626         } else
2627             gv = NULL;
2628     }
2629     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2630     /* start is the beginning of the possible filehandle/object,
2631      * and s is the end of it
2632      * tmpbuf is a copy of it
2633      */
2634
2635     if (*start == '$') {
2636         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
2637             return 0;
2638 #ifdef PERL_MAD
2639         len = start - SvPVX(PL_linestr);
2640 #endif
2641         s = PEEKSPACE(s);
2642 #ifdef PERL_MAD
2643         start = SvPVX(PL_linestr) + len;
2644 #endif
2645         PL_bufptr = start;
2646         PL_expect = XREF;
2647         return *s == '(' ? FUNCMETH : METHOD;
2648     }
2649     if (!keyword(tmpbuf, len, 0)) {
2650         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
2651             len -= 2;
2652             tmpbuf[len] = '\0';
2653 #ifdef PERL_MAD
2654             soff = s - SvPVX(PL_linestr);
2655 #endif
2656             goto bare_package;
2657         }
2658         indirgv = gv_fetchpvn_flags(tmpbuf, len, 0, SVt_PVCV);
2659         if (indirgv && GvCVu(indirgv))
2660             return 0;
2661         /* filehandle or package name makes it a method */
2662         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
2663 #ifdef PERL_MAD
2664             soff = s - SvPVX(PL_linestr);
2665 #endif
2666             s = PEEKSPACE(s);
2667             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
2668                 return 0;       /* no assumptions -- "=>" quotes bearword */
2669       bare_package:
2670             start_force(PL_curforce);
2671             NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0,
2672                                                    newSVpvn(tmpbuf,len));
2673             NEXTVAL_NEXTTOKE.opval->op_private = OPpCONST_BARE;
2674             if (PL_madskills)
2675                 curmad('X', newSVpvn(start,SvPVX(PL_linestr) + soff - start));
2676             PL_expect = XTERM;
2677             force_next(WORD);
2678             PL_bufptr = s;
2679 #ifdef PERL_MAD
2680             PL_bufptr = SvPVX(PL_linestr) + soff; /* restart before space */
2681 #endif
2682             return *s == '(' ? FUNCMETH : METHOD;
2683         }
2684     }
2685     return 0;
2686 }
2687
2688 /*
2689  * S_incl_perldb
2690  * Return a string of Perl code to load the debugger.  If PERL5DB
2691  * is set, it will return the contents of that, otherwise a
2692  * compile-time require of perl5db.pl.
2693  */
2694
2695 STATIC const char*
2696 S_incl_perldb(pTHX)
2697 {
2698     dVAR;
2699     if (PL_perldb) {
2700         const char * const pdb = PerlEnv_getenv("PERL5DB");
2701
2702         if (pdb)
2703             return pdb;
2704         SETERRNO(0,SS_NORMAL);
2705         return "BEGIN { require 'perl5db.pl' }";
2706     }
2707     return "";
2708 }
2709
2710
2711 /* Encoded script support. filter_add() effectively inserts a
2712  * 'pre-processing' function into the current source input stream.
2713  * Note that the filter function only applies to the current source file
2714  * (e.g., it will not affect files 'require'd or 'use'd by this one).
2715  *
2716  * The datasv parameter (which may be NULL) can be used to pass
2717  * private data to this instance of the filter. The filter function
2718  * can recover the SV using the FILTER_DATA macro and use it to
2719  * store private buffers and state information.
2720  *
2721  * The supplied datasv parameter is upgraded to a PVIO type
2722  * and the IoDIRP/IoANY field is used to store the function pointer,
2723  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
2724  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
2725  * private use must be set using malloc'd pointers.
2726  */
2727
2728 SV *
2729 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
2730 {
2731     dVAR;
2732     if (!funcp)
2733         return NULL;
2734
2735     if (!PL_rsfp_filters)
2736         PL_rsfp_filters = newAV();
2737     if (!datasv)
2738         datasv = newSV(0);
2739     SvUPGRADE(datasv, SVt_PVIO);
2740     IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */
2741     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2742     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2743                           FPTR2DPTR(void *, IoANY(datasv)),
2744                           SvPV_nolen(datasv)));
2745     av_unshift(PL_rsfp_filters, 1);
2746     av_store(PL_rsfp_filters, 0, datasv) ;
2747     return(datasv);
2748 }
2749
2750
2751 /* Delete most recently added instance of this filter function. */
2752 void
2753 Perl_filter_del(pTHX_ filter_t funcp)
2754 {
2755     dVAR;
2756     SV *datasv;
2757
2758 #ifdef DEBUGGING
2759     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p",
2760                           FPTR2DPTR(void*, funcp)));
2761 #endif
2762     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2763         return;
2764     /* if filter is on top of stack (usual case) just pop it off */
2765     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2766     if (IoANY(datasv) == FPTR2DPTR(void *, funcp)) {
2767         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2768         IoANY(datasv) = (void *)NULL;
2769         sv_free(av_pop(PL_rsfp_filters));
2770
2771         return;
2772     }
2773     /* we need to search for the correct entry and clear it     */
2774     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2775 }
2776
2777
2778 /* Invoke the idxth filter function for the current rsfp.        */
2779 /* maxlen 0 = read one text line */
2780 I32
2781 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2782 {
2783     dVAR;
2784     filter_t funcp;
2785     SV *datasv = NULL;
2786     /* This API is bad. It should have been using unsigned int for maxlen.
2787        Not sure if we want to change the API, but if not we should sanity
2788        check the value here.  */
2789     const unsigned int correct_length
2790         = maxlen < 0 ?
2791 #ifdef PERL_MICRO
2792         0x7FFFFFFF
2793 #else
2794         INT_MAX
2795 #endif
2796         : maxlen;
2797
2798     if (!PL_rsfp_filters)
2799         return -1;
2800     if (idx > AvFILLp(PL_rsfp_filters)) {       /* Any more filters?    */
2801         /* Provide a default input filter to make life easy.    */
2802         /* Note that we append to the line. This is handy.      */
2803         DEBUG_P(PerlIO_printf(Perl_debug_log,
2804                               "filter_read %d: from rsfp\n", idx));
2805         if (correct_length) {
2806             /* Want a block */
2807             int len ;
2808             const int old_len = SvCUR(buf_sv);
2809
2810             /* ensure buf_sv is large enough */
2811             SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ;
2812             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len,
2813                                    correct_length)) <= 0) {
2814                 if (PerlIO_error(PL_rsfp))
2815                     return -1;          /* error */
2816                 else
2817                     return 0 ;          /* end of file */
2818             }
2819             SvCUR_set(buf_sv, old_len + len) ;
2820         } else {
2821             /* Want a line */
2822             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2823                 if (PerlIO_error(PL_rsfp))
2824                     return -1;          /* error */
2825                 else
2826                     return 0 ;          /* end of file */
2827             }
2828         }
2829         return SvCUR(buf_sv);
2830     }
2831     /* Skip this filter slot if filter has been deleted */
2832     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef) {
2833         DEBUG_P(PerlIO_printf(Perl_debug_log,
2834                               "filter_read %d: skipped (filter deleted)\n",
2835                               idx));
2836         return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */
2837     }
2838     /* Get function pointer hidden within datasv        */
2839     funcp = DPTR2FPTR(filter_t, IoANY(datasv));
2840     DEBUG_P(PerlIO_printf(Perl_debug_log,
2841                           "filter_read %d: via function %p (%s)\n",
2842                           idx, (void*)datasv, SvPV_nolen_const(datasv)));
2843     /* Call function. The function is expected to       */
2844     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2845     /* Return: <0:error, =0:eof, >0:not eof             */
2846     return (*funcp)(aTHX_ idx, buf_sv, correct_length);
2847 }
2848
2849 STATIC char *
2850 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2851 {
2852     dVAR;
2853 #ifdef PERL_CR_FILTER
2854     if (!PL_rsfp_filters) {
2855         filter_add(S_cr_textfilter,NULL);
2856     }
2857 #endif
2858     if (PL_rsfp_filters) {
2859         if (!append)
2860             SvCUR_set(sv, 0);   /* start with empty line        */
2861         if (FILTER_READ(0, sv, 0) > 0)
2862             return ( SvPVX(sv) ) ;
2863         else
2864             return NULL ;
2865     }
2866     else
2867         return (sv_gets(sv, fp, append));
2868 }
2869
2870 STATIC HV *
2871 S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
2872 {
2873     dVAR;
2874     GV *gv;
2875
2876     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2877         return PL_curstash;
2878
2879     if (len > 2 &&
2880         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2881         (gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVHV)))
2882     {
2883         return GvHV(gv);                        /* Foo:: */
2884     }
2885
2886     /* use constant CLASS => 'MyClass' */
2887     gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV);
2888     if (gv && GvCV(gv)) {
2889         SV * const sv = cv_const_sv(GvCV(gv));
2890         if (sv)
2891             pkgname = SvPV_nolen_const(sv);
2892     }
2893
2894     return gv_stashpv(pkgname, FALSE);
2895 }
2896
2897 /*
2898  * S_readpipe_override
2899  * Check whether readpipe() is overriden, and generates the appropriate
2900  * optree, provided sublex_start() is called afterwards.
2901  */
2902 STATIC void
2903 S_readpipe_override(pTHX)
2904 {
2905     GV **gvp;
2906     GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV);
2907     yylval.ival = OP_BACKTICK;
2908     if ((gv_readpipe
2909                 && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))
2910             ||
2911             ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE))
2912              && (gv_readpipe = *gvp) != (GV*)&PL_sv_undef
2913              && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)))
2914     {
2915         PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
2916             append_elem(OP_LIST,
2917                 newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */
2918                 newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe))));
2919     }
2920     else {
2921         set_csh();
2922     }
2923 }
2924
2925 #ifdef PERL_MAD
2926  /*
2927  * Perl_madlex
2928  * The intent of this yylex wrapper is to minimize the changes to the
2929  * tokener when we aren't interested in collecting madprops.  It remains
2930  * to be seen how successful this strategy will be...
2931  */
2932
2933 int
2934 Perl_madlex(pTHX)
2935 {
2936     int optype;
2937     char *s = PL_bufptr;
2938
2939     /* make sure PL_thiswhite is initialized */
2940     PL_thiswhite = 0;
2941     PL_thismad = 0;
2942
2943     /* just do what yylex would do on pending identifier; leave PL_thiswhite alone */
2944     if (PL_pending_ident)
2945         return S_pending_ident(aTHX);
2946
2947     /* previous token ate up our whitespace? */
2948     if (!PL_lasttoke && PL_nextwhite) {
2949         PL_thiswhite = PL_nextwhite;
2950         PL_nextwhite = 0;
2951     }
2952
2953     /* isolate the token, and figure out where it is without whitespace */
2954     PL_realtokenstart = -1;
2955     PL_thistoken = 0;
2956     optype = yylex();
2957     s = PL_bufptr;
2958     assert(PL_curforce < 0);
2959
2960     if (!PL_thismad || PL_thismad->mad_key == '^') {    /* not forced already? */
2961         if (!PL_thistoken) {
2962             if (PL_realtokenstart < 0 || !CopLINE(PL_curcop))
2963                 PL_thistoken = newSVpvs("");
2964             else {
2965                 char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart;
2966                 PL_thistoken = newSVpvn(tstart, s - tstart);
2967             }
2968         }
2969         if (PL_thismad) /* install head */
2970             CURMAD('X', PL_thistoken);
2971     }
2972
2973     /* last whitespace of a sublex? */
2974     if (optype == ')' && PL_endwhite) {
2975         CURMAD('X', PL_endwhite);
2976     }
2977
2978     if (!PL_thismad) {
2979
2980         /* if no whitespace and we're at EOF, bail.  Otherwise fake EOF below. */
2981         if (!PL_thiswhite && !PL_endwhite && !optype) {
2982             sv_free(PL_thistoken);
2983             PL_thistoken = 0;
2984             return 0;
2985         }
2986
2987         /* put off final whitespace till peg */
2988         if (optype == ';' && !PL_rsfp) {
2989             PL_nextwhite = PL_thiswhite;
2990             PL_thiswhite = 0;
2991         }
2992         else if (PL_thisopen) {
2993             CURMAD('q', PL_thisopen);
2994             if (PL_thistoken)
2995                 sv_free(PL_thistoken);
2996             PL_thistoken = 0;
2997         }
2998         else {
2999             /* Store actual token text as madprop X */
3000             CURMAD('X', PL_thistoken);
3001         }
3002
3003         if (PL_thiswhite) {
3004             /* add preceding whitespace as madprop _ */
3005             CURMAD('_', PL_thiswhite);
3006         }
3007
3008         if (PL_thisstuff) {
3009             /* add quoted material as madprop = */
3010             CURMAD('=', PL_thisstuff);
3011         }
3012
3013         if (PL_thisclose) {
3014             /* add terminating quote as madprop Q */
3015             CURMAD('Q', PL_thisclose);
3016         }
3017     }
3018
3019     /* special processing based on optype */
3020
3021     switch (optype) {
3022
3023     /* opval doesn't need a TOKEN since it can already store mp */
3024     case WORD:
3025     case METHOD:
3026     case FUNCMETH:
3027     case THING:
3028     case PMFUNC:
3029     case PRIVATEREF:
3030     case FUNC0SUB:
3031     case UNIOPSUB:
3032     case LSTOPSUB:
3033         if (yylval.opval)
3034             append_madprops(PL_thismad, yylval.opval, 0);
3035         PL_thismad = 0;
3036         return optype;
3037
3038     /* fake EOF */
3039     case 0:
3040         optype = PEG;
3041         if (PL_endwhite) {
3042             addmad(newMADsv('p', PL_endwhite), &PL_thismad, 0);
3043             PL_endwhite = 0;
3044         }
3045         break;
3046
3047     case ']':
3048     case '}':
3049         if (PL_faketokens)
3050             break;
3051         /* remember any fake bracket that lexer is about to discard */
3052         if (PL_lex_brackets == 1 &&
3053             ((expectation)PL_lex_brackstack[0] & XFAKEBRACK))
3054         {
3055             s = PL_bufptr;
3056             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3057                 s++;
3058             if (*s == '}') {
3059                 PL_thiswhite = newSVpvn(PL_bufptr, ++s - PL_bufptr);
3060                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3061                 PL_thiswhite = 0;
3062                 PL_bufptr = s - 1;
3063                 break;  /* don't bother looking for trailing comment */
3064             }
3065             else
3066                 s = PL_bufptr;
3067         }
3068         if (optype == ']')
3069             break;
3070         /* FALLTHROUGH */
3071
3072     /* attach a trailing comment to its statement instead of next token */
3073     case ';':
3074         if (PL_faketokens)
3075             break;
3076         if (PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == optype) {
3077             s = PL_bufptr;
3078             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
3079                 s++;
3080             if (*s == '\n' || *s == '#') {
3081                 while (s < PL_bufend && *s != '\n')
3082                     s++;
3083                 if (s < PL_bufend)
3084                     s++;
3085                 PL_thiswhite = newSVpvn(PL_bufptr, s - PL_bufptr);
3086                 addmad(newMADsv('#', PL_thiswhite), &PL_thismad, 0);
3087                 PL_thiswhite = 0;
3088                 PL_bufptr = s;
3089             }
3090         }
3091         break;
3092
3093     /* pval */
3094     case LABEL:
3095         break;
3096
3097     /* ival */
3098     default:
3099         break;
3100
3101     }
3102
3103     /* Create new token struct.  Note: opvals return early above. */
3104     yylval.tkval = newTOKEN(optype, yylval, PL_thismad);
3105     PL_thismad = 0;
3106     return optype;
3107 }
3108 #endif
3109
3110 STATIC char *
3111 S_tokenize_use(pTHX_ int is_use, char *s) {
3112     dVAR;
3113     if (PL_expect != XSTATE)
3114         yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
3115                     is_use ? "use" : "no"));
3116     s = SKIPSPACE1(s);
3117     if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
3118         s = force_version(s, TRUE);
3119         if (*s == ';' || (s = SKIPSPACE1(s), *s == ';')) {
3120             start_force(PL_curforce);
3121             NEXTVAL_NEXTTOKE.opval = NULL;
3122             force_next(WORD);
3123         }
3124         else if (*s == 'v') {
3125             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3126             s = force_version(s, FALSE);
3127         }
3128     }
3129     else {
3130         s = force_word(s,WORD,FALSE,TRUE,FALSE);
3131         s = force_version(s, FALSE);
3132     }
3133     yylval.ival = is_use;
3134     return s;
3135 }
3136 #ifdef DEBUGGING
3137     static const char* const exp_name[] =
3138         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
3139           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
3140         };
3141 #endif
3142
3143 /*
3144   yylex
3145
3146   Works out what to call the token just pulled out of the input
3147   stream.  The yacc parser takes care of taking the ops we return and
3148   stitching them into a tree.
3149
3150   Returns:
3151     PRIVATEREF
3152
3153   Structure:
3154       if read an identifier
3155           if we're in a my declaration
3156               croak if they tried to say my($foo::bar)
3157               build the ops for a my() declaration
3158           if it's an access to a my() variable
3159               are we in a sort block?
3160                   croak if my($a); $a <=> $b
3161               build ops for access to a my() variable
3162           if in a dq string, and they've said @foo and we can't find @foo
3163               croak
3164           build ops for a bareword
3165       if we already built the token before, use it.
3166 */
3167
3168
3169 #ifdef __SC__
3170 #pragma segment Perl_yylex
3171 #endif
3172 int
3173 Perl_yylex(pTHX)
3174 {
3175     dVAR;
3176     register char *s = PL_bufptr;
3177     register char *d;
3178     STRLEN len;
3179     bool bof = FALSE;
3180
3181     /* orig_keyword, gvp, and gv are initialized here because
3182      * jump to the label just_a_word_zero can bypass their
3183      * initialization later. */
3184     I32 orig_keyword = 0;
3185     GV *gv = NULL;
3186     GV **gvp = NULL;
3187
3188     DEBUG_T( {
3189         SV* tmp = newSVpvs("");
3190         PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
3191             (IV)CopLINE(PL_curcop),
3192             lex_state_names[PL_lex_state],
3193             exp_name[PL_expect],
3194             pv_display(tmp, s, strlen(s), 0, 60));
3195         SvREFCNT_dec(tmp);
3196     } );
3197     /* check if there's an identifier for us to look at */
3198     if (PL_pending_ident)
3199         return REPORT(S_pending_ident(aTHX));
3200
3201     /* no identifier pending identification */
3202
3203     switch (PL_lex_state) {
3204 #ifdef COMMENTARY
3205     case LEX_NORMAL:            /* Some compilers will produce faster */
3206     case LEX_INTERPNORMAL:      /* code if we comment these out. */
3207         break;
3208 #endif
3209
3210     /* when we've already built the next token, just pull it out of the queue */
3211     case LEX_KNOWNEXT:
3212 #ifdef PERL_MAD
3213         PL_lasttoke--;
3214         yylval = PL_nexttoke[PL_lasttoke].next_val;
3215         if (PL_madskills) {
3216             PL_thismad = PL_nexttoke[PL_lasttoke].next_mad;
3217             PL_nexttoke[PL_lasttoke].next_mad = 0;
3218             if (PL_thismad && PL_thismad->mad_key == '_') {
3219                 PL_thiswhite = (SV*)PL_thismad->mad_val;
3220                 PL_thismad->mad_val = 0;
3221                 mad_free(PL_thismad);
3222                 PL_thismad = 0;
3223             }
3224         }
3225         if (!PL_lasttoke) {
3226             PL_lex_state = PL_lex_defer;
3227             PL_expect = PL_lex_expect;
3228             PL_lex_defer = LEX_NORMAL;
3229             if (!PL_nexttoke[PL_lasttoke].next_type)
3230                 return yylex();
3231         }
3232 #else
3233         PL_nexttoke--;
3234         yylval = PL_nextval[PL_nexttoke];
3235         if (!PL_nexttoke) {
3236             PL_lex_state = PL_lex_defer;
3237             PL_expect = PL_lex_expect;
3238             PL_lex_defer = LEX_NORMAL;
3239         }
3240 #endif
3241 #ifdef PERL_MAD
3242         /* FIXME - can these be merged?  */
3243         return(PL_nexttoke[PL_lasttoke].next_type);
3244 #else
3245         return REPORT(PL_nexttype[PL_nexttoke]);
3246 #endif
3247
3248     /* interpolated case modifiers like \L \U, including \Q and \E.
3249        when we get here, PL_bufptr is at the \
3250     */
3251     case LEX_INTERPCASEMOD:
3252 #ifdef DEBUGGING
3253         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
3254             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
3255 #endif
3256         /* handle \E or end of string */
3257         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
3258             /* if at a \E */
3259             if (PL_lex_casemods) {
3260                 const char oldmod = PL_lex_casestack[--PL_lex_casemods];
3261                 PL_lex_casestack[PL_lex_casemods] = '\0';
3262
3263                 if (PL_bufptr != PL_bufend
3264                     && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) {
3265                     PL_bufptr += 2;
3266                     PL_lex_state = LEX_INTERPCONCAT;
3267 #ifdef PERL_MAD
3268                     if (PL_madskills)
3269                         PL_thistoken = newSVpvs("\\E");
3270 #endif
3271                 }
3272                 return REPORT(')');
3273             }
3274 #ifdef PERL_MAD
3275             while (PL_bufptr != PL_bufend &&
3276               PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') {
3277                 if (!PL_thiswhite)
3278                     PL_thiswhite = newSVpvs("");
3279                 sv_catpvn(PL_thiswhite, PL_bufptr, 2);
3280                 PL_bufptr += 2;
3281             }
3282 #else
3283             if (PL_bufptr != PL_bufend)
3284                 PL_bufptr += 2;
3285 #endif
3286             PL_lex_state = LEX_INTERPCONCAT;
3287             return yylex();
3288         }
3289         else {
3290             DEBUG_T({ PerlIO_printf(Perl_debug_log,
3291               "### Saw case modifier\n"); });
3292             s = PL_bufptr + 1;
3293             if (s[1] == '\\' && s[2] == 'E') {
3294 #ifdef PERL_MAD
3295                 if (!PL_thiswhite)
3296                     PL_thiswhite = newSVpvs("");
3297                 sv_catpvn(PL_thiswhite, PL_bufptr, 4);
3298 #endif
3299                 PL_bufptr = s + 3;
3300                 PL_lex_state = LEX_INTERPCONCAT;
3301                 return yylex();
3302             }
3303             else {
3304                 I32 tmp;
3305                 if (!PL_madskills) /* when just compiling don't need correct */
3306                     if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
3307                         tmp = *s, *s = s[2], s[2] = (char)tmp;  /* misordered... */
3308                 if ((*s == 'L' || *s == 'U') &&
3309                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
3310                     PL_lex_casestack[--PL_lex_casemods] = '\0';
3311                     return REPORT(')');
3312                 }
3313                 if (PL_lex_casemods > 10)
3314                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
3315                 PL_lex_casestack[PL_lex_casemods++] = *s;
3316                 PL_lex_casestack[PL_lex_casemods] = '\0';
3317                 PL_lex_state = LEX_INTERPCONCAT;
3318                 start_force(PL_curforce);
3319                 NEXTVAL_NEXTTOKE.ival = 0;
3320                 force_next('(');
3321                 start_force(PL_curforce);
3322                 if (*s == 'l')
3323                     NEXTVAL_NEXTTOKE.ival = OP_LCFIRST;
3324                 else if (*s == 'u')
3325                     NEXTVAL_NEXTTOKE.ival = OP_UCFIRST;
3326                 else if (*s == 'L')
3327                     NEXTVAL_NEXTTOKE.ival = OP_LC;
3328                 else if (*s == 'U')
3329                     NEXTVAL_NEXTTOKE.ival = OP_UC;
3330                 else if (*s == 'Q')
3331                     NEXTVAL_NEXTTOKE.ival = OP_QUOTEMETA;
3332                 else
3333                     Perl_croak(aTHX_ "panic: yylex");
3334                 if (PL_madskills) {
3335                     SV* const tmpsv = newSVpvs("");
3336                     Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s);
3337                     curmad('_', tmpsv);
3338                 }
3339                 PL_bufptr = s + 1;
3340             }
3341             force_next(FUNC);
3342             if (PL_lex_starts) {
3343                 s = PL_bufptr;
3344                 PL_lex_starts = 0;
3345 #ifdef PERL_MAD
3346                 if (PL_madskills) {
3347                     if (PL_thistoken)
3348                         sv_free(PL_thistoken);
3349                     PL_thistoken = newSVpvs("");
3350                 }
3351 #endif
3352                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3353                 if (PL_lex_casemods == 1 && PL_lex_inpat)
3354                     OPERATOR(',');
3355                 else
3356                     Aop(OP_CONCAT);
3357             }
3358             else
3359                 return yylex();
3360         }
3361
3362     case LEX_INTERPPUSH:
3363         return REPORT(sublex_push());
3364
3365     case LEX_INTERPSTART:
3366         if (PL_bufptr == PL_bufend)
3367             return REPORT(sublex_done());
3368         DEBUG_T({ PerlIO_printf(Perl_debug_log,
3369               "### Interpolated variable\n"); });
3370         PL_expect = XTERM;
3371         PL_lex_dojoin = (*PL_bufptr == '@');
3372         PL_lex_state = LEX_INTERPNORMAL;
3373         if (PL_lex_dojoin) {
3374             start_force(PL_curforce);
3375             NEXTVAL_NEXTTOKE.ival = 0;
3376             force_next(',');
3377             start_force(PL_curforce);
3378             force_ident("\"", '$');
3379             start_force(PL_curforce);
3380             NEXTVAL_NEXTTOKE.ival = 0;
3381             force_next('$');
3382             start_force(PL_curforce);
3383             NEXTVAL_NEXTTOKE.ival = 0;
3384             force_next('(');
3385             start_force(PL_curforce);
3386             NEXTVAL_NEXTTOKE.ival = OP_JOIN;    /* emulate join($", ...) */
3387             force_next(FUNC);
3388         }
3389         if (PL_lex_starts++) {
3390             s = PL_bufptr;
3391 #ifdef PERL_MAD
3392             if (PL_madskills) {
3393                 if (PL_thistoken)
3394                     sv_free(PL_thistoken);
3395                 PL_thistoken = newSVpvs("");
3396             }
3397 #endif
3398             /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3399             if (!PL_lex_casemods && PL_lex_inpat)
3400                 OPERATOR(',');
3401             else
3402                 Aop(OP_CONCAT);
3403         }
3404         return yylex();
3405
3406     case LEX_INTERPENDMAYBE:
3407         if (intuit_more(PL_bufptr)) {
3408             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
3409             break;
3410         }
3411         /* FALL THROUGH */
3412
3413     case LEX_INTERPEND:
3414         if (PL_lex_dojoin) {
3415             PL_lex_dojoin = FALSE;
3416             PL_lex_state = LEX_INTERPCONCAT;
3417 #ifdef PERL_MAD
3418             if (PL_madskills) {
3419                 if (PL_thistoken)
3420                     sv_free(PL_thistoken);
3421                 PL_thistoken = newSVpvs("");
3422             }
3423 #endif
3424             return REPORT(')');
3425         }
3426         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
3427             && SvEVALED(PL_lex_repl))
3428         {
3429             if (PL_bufptr != PL_bufend)
3430                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
3431             PL_lex_repl = NULL;
3432         }
3433         /* FALLTHROUGH */
3434     case LEX_INTERPCONCAT:
3435 #ifdef DEBUGGING
3436         if (PL_lex_brackets)
3437             Perl_croak(aTHX_ "panic: INTERPCONCAT");
3438 #endif
3439         if (PL_bufptr == PL_bufend)
3440             return REPORT(sublex_done());
3441
3442         if (SvIVX(PL_linestr) == '\'') {
3443             SV *sv = newSVsv(PL_linestr);
3444             if (!PL_lex_inpat)
3445                 sv = tokeq(sv);
3446             else if ( PL_hints & HINT_NEW_RE )
3447                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
3448             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3449             s = PL_bufend;
3450         }
3451         else {
3452             s = scan_const(PL_bufptr);
3453             if (*s == '\\')
3454                 PL_lex_state = LEX_INTERPCASEMOD;
3455             else
3456                 PL_lex_state = LEX_INTERPSTART;
3457         }
3458
3459         if (s != PL_bufptr) {
3460             start_force(PL_curforce);
3461             if (PL_madskills) {
3462                 curmad('X', newSVpvn(PL_bufptr,s-PL_bufptr));
3463             }
3464             NEXTVAL_NEXTTOKE = yylval;
3465             PL_expect = XTERM;
3466             force_next(THING);
3467             if (PL_lex_starts++) {
3468 #ifdef PERL_MAD
3469                 if (PL_madskills) {
3470                     if (PL_thistoken)
3471                         sv_free(PL_thistoken);
3472                     PL_thistoken = newSVpvs("");
3473                 }
3474 #endif
3475                 /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */
3476                 if (!PL_lex_casemods && PL_lex_inpat)
3477                     OPERATOR(',');
3478                 else
3479                     Aop(OP_CONCAT);
3480             }
3481             else {
3482                 PL_bufptr = s;
3483                 return yylex();
3484             }
3485         }
3486
3487         return yylex();
3488     case LEX_FORMLINE:
3489         PL_lex_state = LEX_NORMAL;
3490         s = scan_formline(PL_bufptr);
3491         if (!PL_lex_formbrack)
3492             goto rightbracket;
3493         OPERATOR(';');
3494     }
3495
3496     s = PL_bufptr;
3497     PL_oldoldbufptr = PL_oldbufptr;
3498     PL_oldbufptr = s;
3499
3500   retry:
3501 #ifdef PERL_MAD
3502     if (PL_thistoken) {
3503         sv_free(PL_thistoken);
3504         PL_thistoken = 0;
3505     }
3506     PL_realtokenstart = s - SvPVX(PL_linestr);  /* assume but undo on ws */
3507 #endif
3508     switch (*s) {
3509     default:
3510         if (isIDFIRST_lazy_if(s,UTF))
3511             goto keylookup;
3512         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
3513     case 4:
3514     case 26:
3515         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
3516     case 0:
3517 #ifdef PERL_MAD
3518         if (PL_madskills)
3519             PL_faketokens = 0;
3520 #endif
3521         if (!PL_rsfp) {
3522             PL_last_uni = 0;
3523             PL_last_lop = 0;
3524             if (PL_lex_brackets) {
3525                 yyerror((const char *)
3526                         (PL_lex_formbrack
3527                          ? "Format not terminated"
3528                          : "Missing right curly or square bracket"));
3529             }
3530             DEBUG_T( { PerlIO_printf(Perl_debug_log,
3531                         "### Tokener got EOF\n");
3532             } );
3533             TOKEN(0);
3534         }
3535         if (s++ < PL_bufend)
3536             goto retry;                 /* ignore stray nulls */
3537         PL_last_uni = 0;
3538         PL_last_lop = 0;
3539         if (!PL_in_eval && !PL_preambled) {
3540             PL_preambled = TRUE;
3541 #ifdef PERL_MAD
3542             if (PL_madskills)
3543                 PL_faketokens = 1;
3544 #endif
3545             sv_setpv(PL_linestr,incl_perldb());
3546             if (SvCUR(PL_linestr))
3547                 sv_catpvs(PL_linestr,";");
3548             if (PL_preambleav){
3549                 while(AvFILLp(PL_preambleav) >= 0) {
3550                     SV *tmpsv = av_shift(PL_preambleav);
3551                     sv_catsv(PL_linestr, tmpsv);
3552                     sv_catpvs(PL_linestr, ";");
3553                     sv_free(tmpsv);
3554                 }
3555                 sv_free((SV*)PL_preambleav);
3556                 PL_preambleav = NULL;
3557             }
3558             if (PL_minus_n || PL_minus_p) {
3559                 sv_catpvs(PL_linestr, "LINE: while (<>) {");
3560                 if (PL_minus_l)
3561                     sv_catpvs(PL_linestr,"chomp;");
3562                 if (PL_minus_a) {
3563                     if (PL_minus_F) {
3564                         if ((*PL_splitstr == '/' || *PL_splitstr == '\''
3565                              || *PL_splitstr == '"')
3566                               && strchr(PL_splitstr + 1, *PL_splitstr))
3567                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
3568                         else {
3569                             /* "q\0${splitstr}\0" is legal perl. Yes, even NUL
3570                                bytes can be used as quoting characters.  :-) */
3571                             const char *splits = PL_splitstr;
3572                             sv_catpvs(PL_linestr, "our @F=split(q\0");
3573                             do {
3574                                 /* Need to \ \s  */
3575                                 if (*splits == '\\')
3576                                     sv_catpvn(PL_linestr, splits, 1);
3577                                 sv_catpvn(PL_linestr, splits, 1);
3578                             } while (*splits++);
3579                             /* This loop will embed the trailing NUL of
3580                                PL_linestr as the last thing it does before
3581                                terminating.  */
3582                             sv_catpvs(PL_linestr, ");");
3583                         }
3584                     }
3585                     else
3586                         sv_catpvs(PL_linestr,"our @F=split(' ');");
3587                 }
3588             }
3589             if (PL_minus_E)
3590                 sv_catpvs(PL_linestr,"use feature ':5.10';");
3591             sv_catpvs(PL_linestr, "\n");
3592             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3593             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3594             PL_last_lop = PL_last_uni = NULL;
3595             if (PERLDB_LINE && PL_curstash != PL_debstash)
3596                 update_debugger_info(PL_linestr, NULL, 0);
3597             goto retry;
3598         }
3599         do {
3600             bof = PL_rsfp ? TRUE : FALSE;
3601             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == NULL) {
3602               fake_eof:
3603 #ifdef PERL_MAD
3604                 PL_realtokenstart = -1;
3605 #endif
3606                 if (PL_rsfp) {
3607                     if (PL_preprocess && !PL_in_eval)
3608                         (void)PerlProc_pclose(PL_rsfp);
3609                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
3610                         PerlIO_clearerr(PL_rsfp);
3611                     else
3612                         (void)PerlIO_close(PL_rsfp);
3613                     PL_rsfp = NULL;
3614                     PL_doextract = FALSE;
3615                 }
3616                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
3617 #ifdef PERL_MAD
3618                     if (PL_madskills)
3619                         PL_faketokens = 1;
3620 #endif
3621                     sv_setpv(PL_linestr,
3622                              (const char *)
3623                              (PL_minus_p
3624                               ? ";}continue{print;}" : ";}"));
3625                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3626                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3627                     PL_last_lop = PL_last_uni = NULL;
3628                     PL_minus_n = PL_minus_p = 0;
3629                     goto retry;
3630                 }
3631                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3632                 PL_last_lop = PL_last_uni = NULL;
3633                 sv_setpvn(PL_linestr,"",0);
3634                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
3635             }
3636             /* If it looks like the start of a BOM or raw UTF-16,
3637              * check if it in fact is. */
3638             else if (bof &&
3639                      (*s == 0 ||
3640                       *(U8*)s == 0xEF ||
3641                       *(U8*)s >= 0xFE ||
3642                       s[1] == 0)) {
3643 #ifdef PERLIO_IS_STDIO
3644 #  ifdef __GNU_LIBRARY__
3645 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
3646 #      define FTELL_FOR_PIPE_IS_BROKEN
3647 #    endif
3648 #  else
3649 #    ifdef __GLIBC__
3650 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
3651 #        define FTELL_FOR_PIPE_IS_BROKEN
3652 #      endif
3653 #    endif
3654 #  endif
3655 #endif
3656 #ifdef FTELL_FOR_PIPE_IS_BROKEN
3657                 /* This loses the possibility to detect the bof
3658                  * situation on perl -P when the libc5 is being used.
3659                  * Workaround?  Maybe attach some extra state to PL_rsfp?
3660                  */
3661                 if (!PL_preprocess)
3662                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
3663 #else
3664                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
3665 #endif
3666                 if (bof) {
3667                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3668                     s = swallow_bom((U8*)s);
3669                 }
3670             }
3671             if (PL_doextract) {
3672                 /* Incest with pod. */
3673 #ifdef PERL_MAD
3674                 if (PL_madskills)
3675                     sv_catsv(PL_thiswhite, PL_linestr);
3676 #endif
3677                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
3678                     sv_setpvn(PL_linestr, "", 0);
3679                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3680                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3681                     PL_last_lop = PL_last_uni = NULL;
3682                     PL_doextract = FALSE;
3683                 }
3684             }
3685             incline(s);
3686         } while (PL_doextract);
3687         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
3688         if (PERLDB_LINE && PL_curstash != PL_debstash)
3689             update_debugger_info(PL_linestr, NULL, 0);
3690         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3691         PL_last_lop = PL_last_uni = NULL;
3692         if (CopLINE(PL_curcop) == 1) {
3693             while (s < PL_bufend && isSPACE(*s))
3694                 s++;
3695             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
3696                 s++;
3697 #ifdef PERL_MAD
3698             if (PL_madskills)
3699                 PL_thiswhite = newSVpvn(PL_linestart, s - PL_linestart);
3700 #endif
3701             d = NULL;
3702             if (!PL_in_eval) {
3703                 if (*s == '#' && *(s+1) == '!')
3704                     d = s + 2;
3705 #ifdef ALTERNATE_SHEBANG
3706                 else {
3707                     static char const as[] = ALTERNATE_SHEBANG;
3708                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
3709                         d = s + (sizeof(as) - 1);
3710                 }
3711 #endif /* ALTERNATE_SHEBANG */
3712             }
3713             if (d) {
3714                 char *ipath;
3715                 char *ipathend;
3716
3717                 while (isSPACE(*d))
3718                     d++;
3719                 ipath = d;
3720                 while (*d && !isSPACE(*d))
3721                     d++;
3722                 ipathend = d;
3723
3724 #ifdef ARG_ZERO_IS_SCRIPT
3725                 if (ipathend > ipath) {
3726                     /*
3727                      * HP-UX (at least) sets argv[0] to the script name,
3728                      * which makes $^X incorrect.  And Digital UNIX and Linux,
3729                      * at least, set argv[0] to the basename of the Perl
3730                      * interpreter. So, having found "#!", we'll set it right.
3731                      */
3732                     SV * const x = GvSV(gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL,
3733                                                     SVt_PV)); /* $^X */
3734                     assert(SvPOK(x) || SvGMAGICAL(x));
3735                     if (sv_eq(x, CopFILESV(PL_curcop))) {
3736                         sv_setpvn(x, ipath, ipathend - ipath);
3737                         SvSETMAGIC(x);
3738                     }
3739                     else {
3740                         STRLEN blen;
3741                         STRLEN llen;
3742                         const char *bstart = SvPV_const(CopFILESV(PL_curcop),blen);
3743                         const char * const lstart = SvPV_const(x,llen);
3744                         if (llen < blen) {
3745                             bstart += blen - llen;
3746                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
3747                                 sv_setpvn(x, ipath, ipathend - ipath);
3748                                 SvSETMAGIC(x);
3749                             }
3750                         }
3751                     }
3752                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
3753                 }
3754 #endif /* ARG_ZERO_IS_SCRIPT */
3755
3756                 /*
3757                  * Look for options.
3758                  */
3759                 d = instr(s,"perl -");
3760                 if (!d) {
3761                     d = instr(s,"perl");
3762 #if defined(DOSISH)
3763                     /* avoid getting into infinite loops when shebang
3764                      * line contains "Perl" rather than "perl" */
3765                     if (!d) {
3766                         for (d = ipathend-4; d >= ipath; --d) {
3767                             if ((*d == 'p' || *d == 'P')
3768                                 && !ibcmp(d, "perl", 4))
3769                             {
3770                                 break;
3771                             }
3772                         }
3773                         if (d < ipath)
3774                             d = NULL;
3775                     }
3776 #endif
3777                 }
3778 #ifdef ALTERNATE_SHEBANG
3779                 /*
3780                  * If the ALTERNATE_SHEBANG on this system starts with a
3781                  * character that can be part of a Perl expression, then if
3782                  * we see it but not "perl", we're probably looking at the
3783                  * start of Perl code, not a request to hand off to some
3784                  * other interpreter.  Similarly, if "perl" is there, but
3785                  * not in the first 'word' of the line, we assume the line
3786                  * contains the start of the Perl program.
3787                  */
3788                 if (d && *s != '#') {
3789                     const char *c = ipath;
3790                     while (*c && !strchr("; \t\r\n\f\v#", *c))
3791                         c++;
3792                     if (c < d)
3793                         d = NULL;       /* "perl" not in first word; ignore */
3794                     else
3795                         *s = '#';       /* Don't try to parse shebang line */
3796                 }
3797 #endif /* ALTERNATE_SHEBANG */
3798 #ifndef MACOS_TRADITIONAL
3799                 if (!d &&
3800                     *s == '#' &&
3801                     ipathend > ipath &&
3802                     !PL_minus_c &&
3803                     !instr(s,"indir") &&
3804                     instr(PL_origargv[0],"perl"))
3805                 {
3806                     dVAR;
3807                     char **newargv;
3808
3809                     *ipathend = '\0';
3810                     s = ipathend + 1;
3811                     while (s < PL_bufend && isSPACE(*s))
3812                         s++;
3813                     if (s < PL_bufend) {
3814                         Newxz(newargv,PL_origargc+3,char*);
3815                         newargv[1] = s;
3816                         while (s < PL_bufend && !isSPACE(*s))
3817                             s++;
3818                         *s = '\0';
3819                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
3820                     }
3821                     else
3822                         newargv = PL_origargv;
3823                     newargv[0] = ipath;
3824                     PERL_FPU_PRE_EXEC
3825                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
3826                     PERL_FPU_POST_EXEC
3827                     Perl_croak(aTHX_ "Can't exec %s", ipath);
3828                 }
3829 #endif
3830                 if (d) {
3831                     while (*d && !isSPACE(*d))
3832                         d++;
3833                     while (SPACE_OR_TAB(*d))
3834                         d++;
3835
3836                     if (*d++ == '-') {
3837                         const bool switches_done = PL_doswitches;
3838                         const U32 oldpdb = PL_perldb;
3839                         const bool oldn = PL_minus_n;
3840                         const bool oldp = PL_minus_p;
3841
3842                         do {
3843                             if (*d == 'M' || *d == 'm' || *d == 'C') {
3844                                 const char * const m = d;
3845                                 while (*d && !isSPACE(*d))
3846                                     d++;
3847                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
3848                                       (int)(d - m), m);
3849                             }
3850                             d = moreswitches(d);
3851                         } while (d);
3852                         if (PL_doswitches && !switches_done) {
3853                             int argc = PL_origargc;
3854                             char **argv = PL_origargv;
3855                             do {
3856                                 argc--,argv++;
3857                             } while (argc && argv[0][0] == '-' && argv[0][1]);
3858                             init_argv_symbols(argc,argv);
3859                         }
3860                         if ((PERLDB_LINE && !oldpdb) ||
3861                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
3862                               /* if we have already added "LINE: while (<>) {",
3863                                  we must not do it again */
3864                         {
3865                             sv_setpvn(PL_linestr, "", 0);
3866                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
3867                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
3868                             PL_last_lop = PL_last_uni = NULL;
3869                             PL_preambled = FALSE;
3870                             if (PERLDB_LINE)
3871                                 (void)gv_fetchfile(PL_origfilename);
3872                             goto retry;
3873                         }
3874                     }
3875                 }
3876             }
3877         }
3878         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3879             PL_bufptr = s;
3880             PL_lex_state = LEX_FORMLINE;
3881             return yylex();
3882         }
3883         goto retry;
3884     case '\r':
3885 #ifdef PERL_STRICT_CR
3886         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
3887         Perl_croak(aTHX_
3888       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
3889 #endif
3890     case ' ': case '\t': case '\f': case 013:
3891 #ifdef MACOS_TRADITIONAL
3892     case '\312':
3893 #endif
3894 #ifdef PERL_MAD
3895         PL_realtokenstart = -1;
3896         s = SKIPSPACE0(s);
3897 #else
3898         s++;
3899 #endif
3900         goto retry;
3901     case '#':
3902     case '\n':
3903 #ifdef PERL_MAD
3904         PL_realtokenstart = -1;
3905         if (PL_madskills)
3906             PL_faketokens = 0;
3907 #endif
3908         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
3909             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
3910                 /* handle eval qq[#line 1 "foo"\n ...] */
3911                 CopLINE_dec(PL_curcop);
3912                 incline(s);
3913             }
3914             if (PL_madskills && !PL_lex_formbrack && !PL_in_eval) {
3915                 s = SKIPSPACE0(s);
3916                 if (!PL_in_eval || PL_rsfp)
3917                     incline(s);
3918             }
3919             else {
3920                 d = s;
3921                 while (d < PL_bufend && *d != '\n')
3922                     d++;
3923                 if (d < PL_bufend)
3924                     d++;
3925                 else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3926                   Perl_croak(aTHX_ "panic: input overflow");
3927 #ifdef PERL_MAD
3928                 if (PL_madskills)
3929                     PL_thiswhite = newSVpvn(s, d - s);
3930 #endif
3931                 s = d;
3932                 incline(s);
3933             }
3934             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
3935                 PL_bufptr = s;
3936                 PL_lex_state = LEX_FORMLINE;
3937                 return yylex();
3938             }
3939         }
3940         else {
3941 #ifdef PERL_MAD
3942             if (PL_madskills && CopLINE(PL_curcop) >= 1 && !PL_lex_formbrack) {
3943                 if (CopLINE(PL_curcop) == 1 && s[0] == '#' && s[1] == '!') {
3944                     PL_faketokens = 0;
3945                     s = SKIPSPACE0(s);
3946                     TOKEN(PEG); /* make sure any #! line is accessible */
3947                 }
3948                 s = SKIPSPACE0(s);
3949             }
3950             else {
3951 /*              if (PL_madskills && PL_lex_formbrack) { */
3952                     d = s;
3953                     while (d < PL_bufend && *d != '\n')
3954                         d++;
3955                     if (d < PL_bufend)
3956                         d++;
3957                     else if (d > PL_bufend) /* Found by Ilya: feed random input to Perl. */
3958                       Perl_croak(aTHX_ "panic: input overflow");
3959                     if (PL_madskills && CopLINE(PL_curcop) >= 1) {
3960                         if (!PL_thiswhite)
3961                             PL_thiswhite = newSVpvs("");
3962                         if (CopLINE(PL_curcop) == 1) {
3963                             sv_setpvn(PL_thiswhite, "", 0);
3964                             PL_faketokens = 0;
3965                         }
3966                         sv_catpvn(PL_thiswhite, s, d - s);
3967                     }
3968                     s = d;
3969 /*              }
3970                 *s = '\0';
3971                 PL_bufend = s; */
3972             }
3973 #else
3974             *s = '\0';
3975             PL_bufend = s;
3976 #endif
3977         }
3978         goto retry;
3979     case '-':
3980         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
3981             I32 ftst = 0;
3982             char tmp;
3983
3984             s++;
3985             PL_bufptr = s;
3986             tmp = *s++;
3987
3988             while (s < PL_bufend && SPACE_OR_TAB(*s))
3989                 s++;
3990
3991             if (strnEQ(s,"=>",2)) {
3992                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
3993                 DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } );
3994                 OPERATOR('-');          /* unary minus */
3995             }
3996             PL_last_uni = PL_oldbufptr;
3997             switch (tmp) {
3998             case 'r': ftst = OP_FTEREAD;        break;
3999             case 'w': ftst = OP_FTEWRITE;       break;
4000             case 'x': ftst = OP_FTEEXEC;        break;
4001             case 'o': ftst = OP_FTEOWNED;       break;
4002             case 'R': ftst = OP_FTRREAD;        break;
4003             case 'W': ftst = OP_FTRWRITE;       break;
4004             case 'X': ftst = OP_FTREXEC;        break;
4005             case 'O': ftst = OP_FTROWNED;       break;
4006             case 'e': ftst = OP_FTIS;           break;
4007             case 'z': ftst = OP_FTZERO;         break;
4008             case 's': ftst = OP_FTSIZE;         break;
4009             case 'f': ftst = OP_FTFILE;         break;
4010             case 'd': ftst = OP_FTDIR;          break;
4011             case 'l': ftst = OP_FTLINK;         break;
4012             case 'p': ftst = OP_FTPIPE;         break;
4013             case 'S': ftst = OP_FTSOCK;         break;
4014             case 'u': ftst = OP_FTSUID;         break;
4015             case 'g': ftst = OP_FTSGID;         break;
4016             case 'k': ftst = OP_FTSVTX;         break;
4017             case 'b': ftst = OP_FTBLK;          break;
4018             case 'c': ftst = OP_FTCHR;          break;
4019             case 't': ftst = OP_FTTTY;          break;
4020             case 'T': ftst = OP_FTTEXT;         break;
4021             case 'B': ftst = OP_FTBINARY;       break;
4022             case 'M': case 'A': case 'C':
4023                 gv_fetchpvs("\024", GV_ADD|GV_NOTQUAL, SVt_PV);
4024                 switch (tmp) {
4025                 case 'M': ftst = OP_FTMTIME;    break;
4026                 case 'A': ftst = OP_FTATIME;    break;
4027                 case 'C': ftst = OP_FTCTIME;    break;
4028                 default:                        break;
4029                 }
4030                 break;
4031             default:
4032                 break;
4033             }
4034             if (ftst) {
4035                 PL_last_lop_op = (OPCODE)ftst;
4036                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4037                         "### Saw file test %c\n", (int)tmp);
4038                 } );
4039                 FTST(ftst);
4040             }
4041             else {
4042                 /* Assume it was a minus followed by a one-letter named
4043                  * subroutine call (or a -bareword), then. */
4044                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
4045                         "### '-%c' looked like a file test but was not\n",
4046                         (int) tmp);
4047                 } );
4048                 s = --PL_bufptr;
4049             }
4050         }
4051         {
4052             const char tmp = *s++;
4053             if (*s == tmp) {
4054                 s++;
4055                 if (PL_expect == XOPERATOR)
4056                     TERM(POSTDEC);
4057                 else
4058                     OPERATOR(PREDEC);
4059             }
4060             else if (*s == '>') {
4061                 s++;
4062                 s = SKIPSPACE1(s);
4063                 if (isIDFIRST_lazy_if(s,UTF)) {
4064                     s = force_word(s,METHOD,FALSE,TRUE,FALSE);
4065                     TOKEN(ARROW);
4066                 }
4067                 else if (*s == '$')
4068                     OPERATOR(ARROW);
4069                 else
4070                     TERM(ARROW);
4071             }
4072             if (PL_expect == XOPERATOR)
4073                 Aop(OP_SUBTRACT);
4074             else {
4075                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4076                     check_uni();
4077                 OPERATOR('-');          /* unary minus */
4078             }
4079         }
4080
4081     case '+':
4082         {
4083             const char tmp = *s++;
4084             if (*s == tmp) {
4085                 s++;
4086                 if (PL_expect == XOPERATOR)
4087                     TERM(POSTINC);
4088                 else
4089                     OPERATOR(PREINC);
4090             }
4091             if (PL_expect == XOPERATOR)
4092                 Aop(OP_ADD);
4093             else {
4094                 if (isSPACE(*s) || !isSPACE(*PL_bufptr))
4095                     check_uni();
4096                 OPERATOR('+');
4097             }
4098         }
4099
4100     case '*':
4101         if (PL_expect != XOPERATOR) {
4102             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4103             PL_expect = XOPERATOR;
4104             force_ident(PL_tokenbuf, '*');
4105             if (!*PL_tokenbuf)
4106                 PREREF('*');
4107             TERM('*');
4108         }
4109         s++;
4110         if (*s == '*') {
4111             s++;
4112             PWop(OP_POW);
4113         }
4114         Mop(OP_MULTIPLY);
4115
4116     case '%':
4117         if (PL_expect == XOPERATOR) {
4118             ++s;
4119             Mop(OP_MODULO);
4120         }
4121         PL_tokenbuf[0] = '%';
4122         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
4123         if (!PL_tokenbuf[1]) {
4124             PREREF('%');
4125         }
4126         PL_pending_ident = '%';
4127         TERM('%');
4128
4129     case '^':
4130         s++;
4131         BOop(OP_BIT_XOR);
4132     case '[':
4133         PL_lex_brackets++;
4134         /* FALL THROUGH */
4135     case '~':
4136         if (s[1] == '~'
4137         && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)
4138         && FEATURE_IS_ENABLED("~~"))
4139         {
4140             s += 2;
4141             Eop(OP_SMARTMATCH);
4142         }
4143     case ',':
4144         {
4145             const char tmp = *s++;
4146             OPERATOR(tmp);
4147         }
4148     case ':':
4149         if (s[1] == ':') {
4150             len = 0;
4151             goto just_a_word_zero_gv;
4152         }
4153         s++;
4154         switch (PL_expect) {
4155             OP *attrs;
4156 #ifdef PERL_MAD
4157             I32 stuffstart;
4158 #endif
4159         case XOPERATOR:
4160             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
4161                 break;
4162             PL_bufptr = s;      /* update in case we back off */
4163             goto grabattrs;
4164         case XATTRBLOCK:
4165             PL_expect = XBLOCK;
4166             goto grabattrs;
4167         case XATTRTERM:
4168             PL_expect = XTERMBLOCK;
4169          grabattrs:
4170 #ifdef PERL_MAD
4171             stuffstart = s - SvPVX(PL_linestr) - 1;
4172 #endif
4173             s = PEEKSPACE(s);
4174             attrs = NULL;
4175             while (isIDFIRST_lazy_if(s,UTF)) {
4176                 I32 tmp;
4177                 SV *sv;
4178                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4179                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) {
4180                     if (tmp < 0) tmp = -tmp;
4181                     switch (tmp) {
4182                     case KEY_or:
4183                     case KEY_and:
4184                     case KEY_err:
4185                     case KEY_for:
4186                     case KEY_unless:
4187                     case KEY_if:
4188                     case KEY_while:
4189                     case KEY_until:
4190                         goto got_attrs;
4191                     default:
4192                         break;
4193                     }
4194                 }
4195                 sv = newSVpvn(s, len);
4196                 if (*d == '(') {
4197                     d = scan_str(d,TRUE,TRUE);
4198                     if (!d) {
4199                         /* MUST advance bufptr here to avoid bogus
4200                            "at end of line" context messages from yyerror().
4201                          */
4202                         PL_bufptr = s + len;
4203                         yyerror("Unterminated attribute parameter in attribute list");
4204                         if (attrs)
4205                             op_free(attrs);
4206                         sv_free(sv);
4207                         return REPORT(0);       /* EOF indicator */
4208                     }
4209                 }
4210                 if (PL_lex_stuff) {
4211                     sv_catsv(sv, PL_lex_stuff);
4212                     attrs = append_elem(OP_LIST, attrs,
4213                                         newSVOP(OP_CONST, 0, sv));
4214                     SvREFCNT_dec(PL_lex_stuff);
4215                     PL_lex_stuff = NULL;
4216                 }
4217                 else {
4218                     if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) {
4219                         sv_free(sv);
4220                         if (PL_in_my == KEY_our) {
4221 #ifdef USE_ITHREADS
4222                             GvUNIQUE_on(cGVOPx_gv(yylval.opval));
4223 #else
4224                             /* skip to avoid loading attributes.pm */
4225 #endif
4226                             deprecate(":unique");
4227                         }
4228                         else
4229                             Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables");
4230                     }
4231
4232                     /* NOTE: any CV attrs applied here need to be part of
4233                        the CVf_BUILTIN_ATTRS define in cv.h! */
4234                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) {
4235                         sv_free(sv);
4236                         CvLVALUE_on(PL_compcv);
4237                     }
4238                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) {
4239                         sv_free(sv);
4240                         CvLOCKED_on(PL_compcv);
4241                     }
4242                     else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) {
4243                         sv_free(sv);
4244                         CvMETHOD_on(PL_compcv);
4245                     }
4246                     else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) {
4247                         sv_free(sv);
4248                         CvASSERTION_on(PL_compcv);
4249                     }
4250                     /* After we've set the flags, it could be argued that
4251                        we don't need to do the attributes.pm-based setting
4252                        process, and shouldn't bother appending recognized
4253                        flags.  To experiment with that, uncomment the
4254                        following "else".  (Note that's already been
4255                        uncommented.  That keeps the above-applied built-in
4256                        attributes from being intercepted (and possibly
4257                        rejected) by a package's attribute routines, but is
4258                        justified by the performance win for the common case
4259                        of applying only built-in attributes.) */
4260                     else
4261                         attrs = append_elem(OP_LIST, attrs,
4262                                             newSVOP(OP_CONST, 0,
4263                                                     sv));
4264                 }
4265                 s = PEEKSPACE(d);
4266                 if (*s == ':' && s[1] != ':')
4267                     s = PEEKSPACE(s+1);
4268                 else if (s == d)
4269                     break;      /* require real whitespace or :'s */
4270                 /* XXX losing whitespace on sequential attributes here */
4271             }
4272             {
4273                 const char tmp
4274                     = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
4275                 if (*s != ';' && *s != '}' && *s != tmp
4276                     && (tmp != '=' || *s != ')')) {
4277                     const char q = ((*s == '\'') ? '"' : '\'');
4278                     /* If here for an expression, and parsed no attrs, back
4279                        off. */
4280                     if (tmp == '=' && !attrs) {
4281                         s = PL_bufptr;
4282                         break;
4283                     }
4284                     /* MUST advance bufptr here to avoid bogus "at end of line"
4285                        context messages from yyerror().
4286                     */
4287                     PL_bufptr = s;
4288                     yyerror( (const char *)
4289                              (*s
4290                               ? Perl_form(aTHX_ "Invalid separator character "
4291                                           "%c%c%c in attribute list", q, *s, q)
4292                               : "Unterminated attribute list" ) );
4293                     if (attrs)
4294                         op_free(attrs);
4295                     OPERATOR(':');
4296                 }
4297             }
4298         got_attrs:
4299             if (attrs) {
4300                 start_force(PL_curforce);
4301                 NEXTVAL_NEXTTOKE.opval = attrs;
4302                 CURMAD('_', PL_nextwhite);
4303                 force_next(THING);
4304             }
4305 #ifdef PERL_MAD
4306             if (PL_madskills) {
4307                 PL_thistoken = newSVpvn(SvPVX(PL_linestr) + stuffstart,
4308                                      (s - SvPVX(PL_linestr)) - stuffstart);
4309             }
4310 #endif
4311             TOKEN(COLONATTR);
4312         }
4313         OPERATOR(':');
4314     case '(':
4315         s++;
4316         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
4317             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
4318         else
4319             PL_expect = XTERM;
4320         s = SKIPSPACE1(s);
4321         TOKEN('(');
4322     case ';':
4323         CLINE;
4324         {
4325             const char tmp = *s++;
4326             OPERATOR(tmp);
4327         }
4328     case ')':
4329         {
4330             const char tmp = *s++;
4331             s = SKIPSPACE1(s);
4332             if (*s == '{')
4333                 PREBLOCK(tmp);
4334             TERM(tmp);
4335         }
4336     case ']':
4337         s++;
4338         if (PL_lex_brackets <= 0)
4339             yyerror("Unmatched right square bracket");
4340         else
4341             --PL_lex_brackets;
4342         if (PL_lex_state == LEX_INTERPNORMAL) {
4343             if (PL_lex_brackets == 0) {
4344                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
4345                     PL_lex_state = LEX_INTERPEND;
4346             }
4347         }
4348         TERM(']');
4349     case '{':
4350       leftbracket:
4351         s++;
4352         if (PL_lex_brackets > 100) {
4353             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
4354         }
4355         switch (PL_expect) {
4356         case XTERM:
4357             if (PL_lex_formbrack) {
4358                 s--;
4359                 PRETERMBLOCK(DO);
4360             }
4361             if (PL_oldoldbufptr == PL_last_lop)
4362                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4363             else
4364                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4365             OPERATOR(HASHBRACK);
4366         case XOPERATOR:
4367             while (s < PL_bufend && SPACE_OR_TAB(*s))
4368                 s++;
4369             d = s;
4370             PL_tokenbuf[0] = '\0';
4371             if (d < PL_bufend && *d == '-') {
4372                 PL_tokenbuf[0] = '-';
4373                 d++;
4374                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4375                     d++;
4376             }
4377             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
4378                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
4379                               FALSE, &len);
4380                 while (d < PL_bufend && SPACE_OR_TAB(*d))
4381                     d++;
4382                 if (*d == '}') {
4383                     const char minus = (PL_tokenbuf[0] == '-');
4384                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
4385                     if (minus)
4386                         force_next('-');
4387                 }
4388             }
4389             /* FALL THROUGH */
4390         case XATTRBLOCK:
4391         case XBLOCK:
4392             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
4393             PL_expect = XSTATE;
4394             break;
4395         case XATTRTERM:
4396         case XTERMBLOCK:
4397             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4398             PL_expect = XSTATE;
4399             break;
4400         default: {
4401                 const char *t;
4402                 if (PL_oldoldbufptr == PL_last_lop)
4403                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
4404                 else
4405                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
4406                 s = SKIPSPACE1(s);
4407                 if (*s == '}') {
4408                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
4409                         PL_expect = XTERM;
4410                         /* This hack is to get the ${} in the message. */
4411                         PL_bufptr = s+1;
4412                         yyerror("syntax error");
4413                         break;
4414                     }
4415                     OPERATOR(HASHBRACK);
4416                 }
4417                 /* This hack serves to disambiguate a pair of curlies
4418                  * as being a block or an anon hash.  Normally, expectation
4419                  * determines that, but in cases where we're not in a
4420                  * position to expect anything in particular (like inside
4421                  * eval"") we have to resolve the ambiguity.  This code
4422                  * covers the case where the first term in the curlies is a
4423                  * quoted string.  Most other cases need to be explicitly
4424                  * disambiguated by prepending a "+" before the opening
4425                  * curly in order to force resolution as an anon hash.
4426                  *
4427                  * XXX should probably propagate the outer expectation
4428                  * into eval"" to rely less on this hack, but that could
4429                  * potentially break current behavior of eval"".
4430                  * GSAR 97-07-21
4431                  */
4432                 t = s;
4433                 if (*s == '\'' || *s == '"' || *s == '`') {
4434                     /* common case: get past first string, handling escapes */
4435                     for (t++; t < PL_bufend && *t != *s;)
4436                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
4437                             t++;
4438                     t++;
4439                 }
4440                 else if (*s == 'q') {
4441                     if (++t < PL_bufend
4442                         && (!isALNUM(*t)
4443                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
4444                                 && !isALNUM(*t))))
4445                     {
4446                         /* skip q//-like construct */
4447                         const char *tmps;
4448                         char open, close, term;
4449                         I32 brackets = 1;
4450
4451                         while (t < PL_bufend && isSPACE(*t))
4452                             t++;
4453                         /* check for q => */
4454                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
4455                             OPERATOR(HASHBRACK);
4456                         }
4457                         term = *t;
4458                         open = term;
4459                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
4460                             term = tmps[5];
4461                         close = term;
4462                         if (open == close)
4463                             for (t++; t < PL_bufend; t++) {
4464                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
4465                                     t++;
4466                                 else if (*t == open)
4467                                     break;
4468                             }
4469                         else {
4470                             for (t++; t < PL_bufend; t++) {
4471                                 if (*t == '\\' && t+1 < PL_bufend)
4472                                     t++;
4473                                 else if (*t == close && --brackets <= 0)
4474                                     break;
4475                                 else if (*t == open)
4476                                     brackets++;
4477                             }
4478                         }
4479                         t++;
4480                     }
4481                     else
4482                         /* skip plain q word */
4483                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4484                              t += UTF8SKIP(t);
4485                 }
4486                 else if (isALNUM_lazy_if(t,UTF)) {
4487                     t += UTF8SKIP(t);
4488                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
4489                          t += UTF8SKIP(t);
4490                 }
4491                 while (t < PL_bufend && isSPACE(*t))
4492                     t++;
4493                 /* if comma follows first term, call it an anon hash */
4494                 /* XXX it could be a comma expression with loop modifiers */
4495                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
4496                                    || (*t == '=' && t[1] == '>')))
4497                     OPERATOR(HASHBRACK);
4498                 if (PL_expect == XREF)
4499                     PL_expect = XTERM;
4500                 else {
4501                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
4502                     PL_expect = XSTATE;
4503                 }
4504             }
4505             break;
4506         }
4507         yylval.ival = CopLINE(PL_curcop);
4508         if (isSPACE(*s) || *s == '#')
4509             PL_copline = NOLINE;   /* invalidate current command line number */
4510         TOKEN('{');
4511     case '}':
4512       rightbracket:
4513         s++;
4514         if (PL_lex_brackets <= 0)
4515             yyerror("Unmatched right curly bracket");
4516         else
4517             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
4518         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
4519             PL_lex_formbrack = 0;
4520         if (PL_lex_state == LEX_INTERPNORMAL) {
4521             if (PL_lex_brackets == 0) {
4522                 if (PL_expect & XFAKEBRACK) {
4523                     PL_expect &= XENUMMASK;
4524                     PL_lex_state = LEX_INTERPEND;
4525                     PL_bufptr = s;
4526 #if 0
4527                     if (PL_madskills) {
4528                         if (!PL_thiswhite)
4529                             PL_thiswhite = newSVpvs("");
4530                         sv_catpvn(PL_thiswhite,"}",1);
4531                     }
4532 #endif
4533                     return yylex();     /* ignore fake brackets */
4534                 }
4535                 if (*s == '-' && s[1] == '>')
4536                     PL_lex_state = LEX_INTERPENDMAYBE;
4537                 else if (*s != '[' && *s != '{')
4538                     PL_lex_state = LEX_INTERPEND;
4539             }
4540         }
4541         if (PL_expect & XFAKEBRACK) {
4542             PL_expect &= XENUMMASK;
4543             PL_bufptr = s;
4544             return yylex();             /* ignore fake brackets */
4545         }
4546         start_force(PL_curforce);
4547         if (PL_madskills) {
4548             curmad('X', newSVpvn(s-1,1));
4549             CURMAD('_', PL_thiswhite);
4550         }
4551         force_next('}');
4552 #ifdef PERL_MAD
4553         if (!PL_thistoken)
4554             PL_thistoken = newSVpvs("");
4555 #endif
4556         TOKEN(';');
4557     case '&':
4558         s++;
4559         if (*s++ == '&')
4560             AOPERATOR(ANDAND);
4561         s--;
4562         if (PL_expect == XOPERATOR) {
4563             if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
4564                 && isIDFIRST_lazy_if(s,UTF))
4565             {
4566                 CopLINE_dec(PL_curcop);
4567                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
4568                 CopLINE_inc(PL_curcop);
4569             }
4570             BAop(OP_BIT_AND);
4571         }
4572
4573         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4574         if (*PL_tokenbuf) {
4575             PL_expect = XOPERATOR;
4576             force_ident(PL_tokenbuf, '&');
4577         }
4578         else
4579             PREREF('&');
4580         yylval.ival = (OPpENTERSUB_AMPER<<8);
4581         TERM('&');
4582
4583     case '|':
4584         s++;
4585         if (*s++ == '|')
4586             AOPERATOR(OROR);
4587         s--;
4588         BOop(OP_BIT_OR);
4589     case '=':
4590         s++;
4591         {
4592             const char tmp = *s++;
4593             if (tmp == '=')
4594                 Eop(OP_EQ);
4595             if (tmp == '>')
4596                 OPERATOR(',');
4597             if (tmp == '~')
4598                 PMop(OP_MATCH);
4599             if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX)
4600                 && strchr("+-*/%.^&|<",tmp))
4601                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4602                             "Reversed %c= operator",(int)tmp);
4603             s--;
4604             if (PL_expect == XSTATE && isALPHA(tmp) &&
4605                 (s == PL_linestart+1 || s[-2] == '\n') )
4606                 {
4607                     if (PL_in_eval && !PL_rsfp) {
4608                         d = PL_bufend;
4609                         while (s < d) {
4610                             if (*s++ == '\n') {
4611                                 incline(s);
4612                                 if (strnEQ(s,"=cut",4)) {
4613                                     s = strchr(s,'\n');
4614                                     if (s)
4615                                         s++;
4616                                     else
4617                                         s = d;
4618                                     incline(s);
4619                                     goto retry;
4620                                 }
4621                             }
4622                         }
4623                         goto retry;
4624                     }
4625 #ifdef PERL_MAD
4626                     if (PL_madskills) {
4627                         if (!PL_thiswhite)
4628                             PL_thiswhite = newSVpvs("");
4629                         sv_catpvn(PL_thiswhite, PL_linestart,
4630                                   PL_bufend - PL_linestart);
4631                     }
4632 #endif
4633                     s = PL_bufend;
4634                     PL_doextract = TRUE;
4635                     goto retry;
4636                 }
4637         }
4638         if (PL_lex_brackets < PL_lex_formbrack) {
4639             const char *t = s;
4640 #ifdef PERL_STRICT_CR
4641             while (SPACE_OR_TAB(*t))
4642 #else
4643             while (SPACE_OR_TAB(*t) || *t == '\r')
4644 #endif
4645                 t++;
4646             if (*t == '\n' || *t == '#') {
4647                 s--;
4648                 PL_expect = XBLOCK;
4649                 goto leftbracket;
4650             }
4651         }
4652         yylval.ival = 0;
4653         OPERATOR(ASSIGNOP);
4654     case '!':
4655         s++;
4656         {
4657             const char tmp = *s++;
4658             if (tmp == '=') {
4659                 /* was this !=~ where !~ was meant?
4660                  * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */
4661
4662                 if (*s == '~' && ckWARN(WARN_SYNTAX)) {
4663                     const char *t = s+1;
4664
4665                     while (t < PL_bufend && isSPACE(*t))
4666                         ++t;
4667
4668                     if (*t == '/' || *t == '?' ||
4669                         ((*t == 'm' || *t == 's' || *t == 'y')
4670                          && !isALNUM(t[1])) ||
4671                         (*t == 't' && t[1] == 'r' && !isALNUM(t[2])))
4672                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4673                                     "!=~ should be !~");
4674                 }
4675                 Eop(OP_NE);
4676             }
4677             if (tmp == '~')
4678                 PMop(OP_NOT);
4679         }
4680         s--;
4681         OPERATOR('!');
4682     case '<':
4683         if (PL_expect != XOPERATOR) {
4684             if (s[1] != '<' && !strchr(s,'>'))
4685                 check_uni();
4686             if (s[1] == '<')
4687                 s = scan_heredoc(s);
4688             else
4689                 s = scan_inputsymbol(s);
4690             TERM(sublex_start());
4691         }
4692         s++;
4693         {
4694             char tmp = *s++;
4695             if (tmp == '<')
4696                 SHop(OP_LEFT_SHIFT);
4697             if (tmp == '=') {
4698                 tmp = *s++;
4699                 if (tmp == '>')
4700                     Eop(OP_NCMP);
4701                 s--;
4702                 Rop(OP_LE);
4703             }
4704         }
4705         s--;
4706         Rop(OP_LT);
4707     case '>':
4708         s++;
4709         {
4710             const char tmp = *s++;
4711             if (tmp == '>')
4712                 SHop(OP_RIGHT_SHIFT);
4713             else if (tmp == '=')
4714                 Rop(OP_GE);
4715         }
4716         s--;
4717         Rop(OP_GT);
4718
4719     case '$':
4720         CLINE;
4721
4722         if (PL_expect == XOPERATOR) {
4723             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4724                 PL_expect = XTERM;
4725                 deprecate_old(commaless_variable_list);
4726                 return REPORT(','); /* grandfather non-comma-format format */
4727             }
4728         }
4729
4730         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
4731             PL_tokenbuf[0] = '@';
4732             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
4733                            sizeof PL_tokenbuf - 1, FALSE);
4734             if (PL_expect == XOPERATOR)
4735                 no_op("Array length", s);
4736             if (!PL_tokenbuf[1])
4737                 PREREF(DOLSHARP);
4738             PL_expect = XOPERATOR;
4739             PL_pending_ident = '#';
4740             TOKEN(DOLSHARP);
4741         }
4742
4743         PL_tokenbuf[0] = '$';
4744         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
4745                        sizeof PL_tokenbuf - 1, FALSE);
4746         if (PL_expect == XOPERATOR)
4747             no_op("Scalar", s);
4748         if (!PL_tokenbuf[1]) {
4749             if (s == PL_bufend)
4750                 yyerror("Final $ should be \\$ or $name");
4751             PREREF('$');
4752         }
4753
4754         /* This kludge not intended to be bulletproof. */
4755         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
4756             yylval.opval = newSVOP(OP_CONST, 0,
4757                                    newSViv(CopARYBASE_get(&PL_compiling)));
4758             yylval.opval->op_private = OPpCONST_ARYBASE;
4759             TERM(THING);
4760         }
4761
4762         d = s;
4763         {
4764             const char tmp = *s;
4765             if (PL_lex_state == LEX_NORMAL)
4766                 s = SKIPSPACE1(s);
4767
4768             if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop)
4769                 && intuit_more(s)) {
4770                 if (*s == '[') {
4771                     PL_tokenbuf[0] = '@';
4772                     if (ckWARN(WARN_SYNTAX)) {
4773                         char *t = s+1;
4774
4775                         while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$')
4776                             t++;
4777                         if (*t++ == ',') {
4778                             PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4779                             while (t < PL_bufend && *t != ']')
4780                                 t++;
4781                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4782                                         "Multidimensional syntax %.*s not supported",
4783                                     (int)((t - PL_bufptr) + 1), PL_bufptr);
4784                         }
4785                     }
4786                 }
4787                 else if (*s == '{') {
4788                     char *t;
4789                     PL_tokenbuf[0] = '%';
4790                     if (strEQ(PL_tokenbuf+1, "SIG")  && ckWARN(WARN_SYNTAX)
4791                         && (t = strchr(s, '}')) && (t = strchr(t, '=')))
4792                         {
4793                             char tmpbuf[sizeof PL_tokenbuf];
4794                             do {
4795                                 t++;
4796                             } while (isSPACE(*t));
4797                             if (isIDFIRST_lazy_if(t,UTF)) {
4798                                 STRLEN dummylen;
4799                                 t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE,
4800                                               &dummylen);
4801                                 while (isSPACE(*t))
4802                                     t++;
4803                                 if (*t == ';' && get_cv(tmpbuf, FALSE))
4804                                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4805                                                 "You need to quote \"%s\"",
4806                                                 tmpbuf);
4807                             }
4808                         }
4809                 }
4810             }
4811
4812             PL_expect = XOPERATOR;
4813             if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
4814                 const bool islop = (PL_last_lop == PL_oldoldbufptr);
4815                 if (!islop || PL_last_lop_op == OP_GREPSTART)
4816                     PL_expect = XOPERATOR;
4817                 else if (strchr("$@\"'`q", *s))
4818                     PL_expect = XTERM;          /* e.g. print $fh "foo" */
4819                 else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
4820                     PL_expect = XTERM;          /* e.g. print $fh &sub */
4821                 else if (isIDFIRST_lazy_if(s,UTF)) {
4822                     char tmpbuf[sizeof PL_tokenbuf];
4823                     int t2;
4824                     scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4825                     if ((t2 = keyword(tmpbuf, len, 0))) {
4826                         /* binary operators exclude handle interpretations */
4827                         switch (t2) {
4828                         case -KEY_x:
4829                         case -KEY_eq:
4830                         case -KEY_ne:
4831                         case -KEY_gt:
4832                         case -KEY_lt:
4833                         case -KEY_ge:
4834                         case -KEY_le:
4835                         case -KEY_cmp:
4836                             break;
4837                         default:
4838                             PL_expect = XTERM;  /* e.g. print $fh length() */
4839                             break;
4840                         }
4841                     }
4842                     else {
4843                         PL_expect = XTERM;      /* e.g. print $fh subr() */
4844                     }
4845                 }
4846                 else if (isDIGIT(*s))
4847                     PL_expect = XTERM;          /* e.g. print $fh 3 */
4848                 else if (*s == '.' && isDIGIT(s[1]))
4849                     PL_expect = XTERM;          /* e.g. print $fh .3 */
4850                 else if ((*s == '?' || *s == '-' || *s == '+')
4851                          && !isSPACE(s[1]) && s[1] != '=')
4852                     PL_expect = XTERM;          /* e.g. print $fh -1 */
4853                 else if (*s == '/' && !isSPACE(s[1]) && s[1] != '='
4854                          && s[1] != '/')
4855                     PL_expect = XTERM;          /* e.g. print $fh /.../
4856                                                    XXX except DORDOR operator
4857                                                 */
4858                 else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])
4859                          && s[2] != '=')
4860                     PL_expect = XTERM;          /* print $fh <<"EOF" */
4861             }
4862         }
4863         PL_pending_ident = '$';
4864         TOKEN('$');
4865
4866     case '@':
4867         if (PL_expect == XOPERATOR)
4868             no_op("Array", s);
4869         PL_tokenbuf[0] = '@';
4870         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
4871         if (!PL_tokenbuf[1]) {
4872             PREREF('@');
4873         }
4874         if (PL_lex_state == LEX_NORMAL)
4875             s = SKIPSPACE1(s);
4876         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
4877             if (*s == '{')
4878                 PL_tokenbuf[0] = '%';
4879
4880             /* Warn about @ where they meant $. */
4881             if (*s == '[' || *s == '{') {
4882                 if (ckWARN(WARN_SYNTAX)) {
4883                     const char *t = s + 1;
4884                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
4885                         t++;
4886                     if (*t == '}' || *t == ']') {
4887                         t++;
4888                         PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */
4889                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
4890                             "Scalar value %.*s better written as $%.*s",
4891                             (int)(t-PL_bufptr), PL_bufptr,
4892                             (int)(t-PL_bufptr-1), PL_bufptr+1);
4893                     }
4894                 }
4895             }
4896         }
4897         PL_pending_ident = '@';
4898         TERM('@');
4899
4900      case '/':                  /* may be division, defined-or, or pattern */
4901         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
4902             s += 2;
4903             AOPERATOR(DORDOR);
4904         }
4905      case '?':                  /* may either be conditional or pattern */
4906          if(PL_expect == XOPERATOR) {
4907              char tmp = *s++;
4908              if(tmp == '?') {
4909                   OPERATOR('?');
4910              }
4911              else {
4912                  tmp = *s++;
4913                  if(tmp == '/') {
4914                      /* A // operator. */
4915                     AOPERATOR(DORDOR);
4916                  }
4917                  else {
4918                      s--;
4919                      Mop(OP_DIVIDE);
4920                  }
4921              }
4922          }
4923          else {
4924              /* Disable warning on "study /blah/" */
4925              if (PL_oldoldbufptr == PL_last_uni
4926               && (*PL_last_uni != 's' || s - PL_last_uni < 5
4927                   || memNE(PL_last_uni, "study", 5)
4928                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
4929               ))
4930                  check_uni();
4931              s = scan_pat(s,OP_MATCH);
4932              TERM(sublex_start());
4933          }
4934
4935     case '.':
4936         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
4937 #ifdef PERL_STRICT_CR
4938             && s[1] == '\n'
4939 #else
4940             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
4941 #endif
4942             && (s == PL_linestart || s[-1] == '\n') )
4943         {
4944             PL_lex_formbrack = 0;
4945             PL_expect = XSTATE;
4946             goto rightbracket;
4947         }
4948         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
4949             char tmp = *s++;
4950             if (*s == tmp) {
4951                 s++;
4952                 if (*s == tmp) {
4953                     s++;
4954                     yylval.ival = OPf_SPECIAL;
4955                 }
4956                 else
4957                     yylval.ival = 0;
4958                 OPERATOR(DOTDOT);
4959             }
4960             if (PL_expect != XOPERATOR)
4961                 check_uni();
4962             Aop(OP_CONCAT);
4963         }
4964         /* FALL THROUGH */
4965     case '0': case '1': case '2': case '3': case '4':
4966     case '5': case '6': case '7': case '8': case '9':
4967         s = scan_num(s, &yylval);
4968         DEBUG_T( { printbuf("### Saw number in %s\n", s); } );
4969         if (PL_expect == XOPERATOR)
4970             no_op("Number",s);
4971         TERM(THING);
4972
4973     case '\'':
4974         s = scan_str(s,!!PL_madskills,FALSE);
4975         DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
4976         if (PL_expect == XOPERATOR) {
4977             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4978                 PL_expect = XTERM;
4979                 deprecate_old(commaless_variable_list);
4980                 return REPORT(','); /* grandfather non-comma-format format */
4981             }
4982             else
4983                 no_op("String",s);
4984         }
4985         if (!s)
4986             missingterm(NULL);
4987         yylval.ival = OP_CONST;
4988         TERM(sublex_start());
4989
4990     case '"':
4991         s = scan_str(s,!!PL_madskills,FALSE);
4992         DEBUG_T( { printbuf("### Saw string before %s\n", s); } );
4993         if (PL_expect == XOPERATOR) {
4994             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
4995                 PL_expect = XTERM;
4996                 deprecate_old(commaless_variable_list);
4997                 return REPORT(','); /* grandfather non-comma-format format */
4998             }
4999             else
5000                 no_op("String",s);
5001         }
5002         if (!s)
5003             missingterm(NULL);
5004         yylval.ival = OP_CONST;
5005         /* FIXME. I think that this can be const if char *d is replaced by
5006            more localised variables.  */
5007         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
5008             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
5009                 yylval.ival = OP_STRINGIFY;
5010                 break;
5011             }
5012         }
5013         TERM(sublex_start());
5014
5015     case '`':
5016         s = scan_str(s,!!PL_madskills,FALSE);
5017         DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } );
5018         if (PL_expect == XOPERATOR)
5019             no_op("Backticks",s);
5020         if (!s)
5021             missingterm(NULL);
5022         readpipe_override();
5023         TERM(sublex_start());
5024
5025     case '\\':
5026         s++;
5027         if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
5028             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
5029                         *s, *s);
5030         if (PL_expect == XOPERATOR)
5031             no_op("Backslash",s);
5032         OPERATOR(REFGEN);
5033
5034     case 'v':
5035         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
5036             char *start = s + 2;
5037             while (isDIGIT(*start) || *start == '_')
5038                 start++;
5039             if (*start == '.' && isDIGIT(start[1])) {
5040                 s = scan_num(s, &yylval);
5041                 TERM(THING);
5042             }
5043             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
5044             else if (!isALPHA(*start) && (PL_expect == XTERM
5045                         || PL_expect == XREF || PL_expect == XSTATE
5046                         || PL_expect == XTERMORDORDOR)) {
5047                 /* XXX Use gv_fetchpvn rather than stomping on a const string */
5048                 const char c = *start;
5049                 GV *gv;
5050                 *start = '\0';
5051                 gv = gv_fetchpv(s, 0, SVt_PVCV);
5052                 *start = c;
5053                 if (!gv) {
5054                     s = scan_num(s, &yylval);
5055                     TERM(THING);
5056                 }
5057             }
5058         }
5059         goto keylookup;
5060     case 'x':
5061         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
5062             s++;
5063             Mop(OP_REPEAT);
5064         }
5065         goto keylookup;
5066
5067     case '_':
5068     case 'a': case 'A':
5069     case 'b': case 'B':
5070     case 'c': case 'C':
5071     case 'd': case 'D':
5072     case 'e': case 'E':
5073     case 'f': case 'F':
5074     case 'g': case 'G':
5075     case 'h': case 'H':
5076     case 'i': case 'I':
5077     case 'j': case 'J':
5078     case 'k': case 'K':
5079     case 'l': case 'L':
5080     case 'm': case 'M':
5081     case 'n': case 'N':
5082     case 'o': case 'O':
5083     case 'p': case 'P':
5084     case 'q': case 'Q':
5085     case 'r': case 'R':
5086     case 's': case 'S':
5087     case 't': case 'T':
5088     case 'u': case 'U':
5089               case 'V':
5090     case 'w': case 'W':
5091               case 'X':
5092     case 'y': case 'Y':
5093     case 'z': case 'Z':
5094
5095       keylookup: {
5096         I32 tmp;
5097
5098         orig_keyword = 0;
5099         gv = NULL;
5100         gvp = NULL;
5101
5102         PL_bufptr = s;
5103         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5104
5105         /* Some keywords can be followed by any delimiter, including ':' */
5106         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
5107                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
5108                              (PL_tokenbuf[0] == 'q' &&
5109                               strchr("qwxr", PL_tokenbuf[1])))));
5110
5111         /* x::* is just a word, unless x is "CORE" */
5112         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
5113             goto just_a_word;
5114
5115         d = s;
5116         while (d < PL_bufend && isSPACE(*d))
5117                 d++;    /* no comments skipped here, or s### is misparsed */
5118
5119         /* Is this a label? */
5120         if (!tmp && PL_expect == XSTATE
5121               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
5122             s = d + 1;
5123             yylval.pval = CopLABEL_alloc(PL_tokenbuf);
5124             CLINE;
5125             TOKEN(LABEL);
5126         }
5127
5128         /* Check for keywords */
5129         tmp = keyword(PL_tokenbuf, len, 0);
5130
5131         /* Is this a word before a => operator? */
5132         if (*d == '=' && d[1] == '>') {
5133             CLINE;
5134             yylval.opval
5135                 = (OP*)newSVOP(OP_CONST, 0,
5136                                S_newSV_maybe_utf8(aTHX_ PL_tokenbuf, len));
5137             yylval.opval->op_private = OPpCONST_BARE;
5138             TERM(WORD);
5139         }
5140
5141         if (tmp < 0) {                  /* second-class keyword? */
5142             GV *ogv = NULL;     /* override (winner) */
5143             GV *hgv = NULL;     /* hidden (loser) */
5144             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
5145                 CV *cv;
5146                 if ((gv = gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVCV)) &&
5147                     (cv = GvCVu(gv)))
5148                 {
5149                     if (GvIMPORTED_CV(gv))
5150                         ogv = gv;
5151                     else if (! CvMETHOD(cv))
5152                         hgv = gv;
5153                 }
5154                 if (!ogv &&
5155                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
5156                     (gv = *gvp) != (GV*)&PL_sv_undef &&
5157                     GvCVu(gv) && GvIMPORTED_CV(gv))
5158                 {
5159                     ogv = gv;
5160                 }
5161             }
5162             if (ogv) {
5163                 orig_keyword = tmp;
5164                 tmp = 0;                /* overridden by import or by GLOBAL */
5165             }
5166             else if (gv && !gvp
5167                      && -tmp==KEY_lock  /* XXX generalizable kludge */
5168                      && GvCVu(gv)
5169                      && !hv_fetchs(GvHVn(PL_incgv), "Thread.pm", FALSE))
5170             {
5171                 tmp = 0;                /* any sub overrides "weak" keyword */
5172             }
5173             else {                      /* no override */
5174                 tmp = -tmp;
5175                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
5176                     Perl_warner(aTHX_ packWARN(WARN_MISC),
5177                             "dump() better written as CORE::dump()");
5178                 }
5179                 gv = NULL;
5180                 gvp = 0;
5181                 if (hgv && tmp != KEY_x && tmp != KEY_CORE
5182                         && ckWARN(WARN_AMBIGUOUS))      /* never ambiguous */
5183                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5184                         "Ambiguous call resolved as CORE::%s(), %s",
5185                          GvENAME(hgv), "qualify as such or use &");
5186             }
5187         }
5188
5189       reserved_word:
5190         switch (tmp) {
5191
5192         default:                        /* not a keyword */
5193             /* Trade off - by using this evil construction we can pull the
5194                variable gv into the block labelled keylookup. If not, then
5195                we have to give it function scope so that the goto from the
5196                earlier ':' case doesn't bypass the initialisation.  */
5197             if (0) {
5198             just_a_word_zero_gv:
5199                 gv = NULL;
5200                 gvp = NULL;
5201                 orig_keyword = 0;
5202             }
5203           just_a_word: {
5204                 SV *sv;
5205                 int pkgname = 0;
5206                 const char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
5207                 CV *cv;
5208 #ifdef PERL_MAD
5209                 SV *nextPL_nextwhite = 0;
5210 #endif
5211
5212
5213                 /* Get the rest if it looks like a package qualifier */
5214
5215                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
5216                     STRLEN morelen;
5217                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
5218                                   TRUE, &morelen);
5219                     if (!morelen)
5220                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
5221                                 *s == '\'' ? "'" : "::");
5222                     len += morelen;
5223                     pkgname = 1;
5224                 }
5225
5226                 if (PL_expect == XOPERATOR) {
5227                     if (PL_bufptr == PL_linestart) {
5228                         CopLINE_dec(PL_curcop);
5229                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
5230                         CopLINE_inc(PL_curcop);
5231                     }
5232                     else
5233                         no_op("Bareword",s);
5234                 }
5235
5236                 /* Look for a subroutine with this name in current package,
5237                    unless name is "Foo::", in which case Foo is a bearword
5238                    (and a package name). */
5239
5240                 if (len > 2 && !PL_madskills &&
5241                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
5242                 {
5243                     if (ckWARN(WARN_BAREWORD)
5244                         && ! gv_fetchpvn_flags(PL_tokenbuf, len, 0, SVt_PVHV))
5245                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
5246                             "Bareword \"%s\" refers to nonexistent package",
5247                              PL_tokenbuf);
5248                     len -= 2;
5249                     PL_tokenbuf[len] = '\0';
5250                     gv = NULL;
5251                     gvp = 0;
5252                 }
5253                 else {
5254                     if (!gv) {
5255                         /* Mustn't actually add anything to a symbol table.
5256                            But also don't want to "initialise" any placeholder
5257                            constants that might already be there into full
5258                            blown PVGVs with attached PVCV.  */
5259                         gv = gv_fetchpvn_flags(PL_tokenbuf, len,
5260                                                GV_NOADD_NOINIT, SVt_PVCV);
5261                     }
5262                     len = 0;
5263                 }
5264
5265                 /* if we saw a global override before, get the right name */
5266
5267                 if (gvp) {
5268                     sv = newSVpvs("CORE::GLOBAL::");
5269                     sv_catpv(sv,PL_tokenbuf);
5270                 }
5271                 else {
5272                     /* If len is 0, newSVpv does strlen(), which is correct.
5273                        If len is non-zero, then it will be the true length,
5274                        and so the scalar will be created correctly.  */
5275                     sv = newSVpv(PL_tokenbuf,len);
5276                 }
5277 #ifdef PERL_MAD
5278                 if (PL_madskills && !PL_thistoken) {
5279                     char *start = SvPVX(PL_linestr) + PL_realtokenstart;
5280                     PL_thistoken = newSVpv(start,s - start);
5281                     PL_realtokenstart = s - SvPVX(PL_linestr);
5282                 }
5283 #endif
5284
5285                 /* Presume this is going to be a bareword of some sort. */
5286
5287                 CLINE;
5288                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
5289                 yylval.opval->op_private = OPpCONST_BARE;
5290                 /* UTF-8 package name? */
5291                 if (UTF && !IN_BYTES &&
5292                     is_utf8_string((U8*)SvPVX_const(sv), SvCUR(sv)))
5293                     SvUTF8_on(sv);
5294
5295                 /* And if "Foo::", then that's what it certainly is. */
5296
5297                 if (len)
5298                     goto safe_bareword;
5299
5300                 /* Do the explicit type check so that we don't need to force
5301                    the initialisation of the symbol table to have a real GV.
5302                    Beware - gv may not really be a PVGV, cv may not really be
5303                    a PVCV, (because of the space optimisations that gv_init
5304                    understands) But they're true if for this symbol there is
5305                    respectively a typeglob and a subroutine.
5306                 */
5307                 cv = gv ? ((SvTYPE(gv) == SVt_PVGV)
5308                     /* Real typeglob, so get the real subroutine: */
5309                            ? GvCVu(gv)
5310                     /* A proxy for a subroutine in this package? */
5311                            : SvOK(gv) ? (CV *) gv : NULL)
5312                     : NULL;
5313
5314                 /* See if it's the indirect object for a list operator. */
5315
5316                 if (PL_oldoldbufptr &&
5317                     PL_oldoldbufptr < PL_bufptr &&
5318                     (PL_oldoldbufptr == PL_last_lop
5319                      || PL_oldoldbufptr == PL_last_uni) &&
5320                     /* NO SKIPSPACE BEFORE HERE! */
5321                     (PL_expect == XREF ||
5322                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
5323                 {
5324                     bool immediate_paren = *s == '(';
5325
5326                     /* (Now we can afford to cross potential line boundary.) */
5327                     s = SKIPSPACE2(s,nextPL_nextwhite);
5328 #ifdef PERL_MAD
5329                     PL_nextwhite = nextPL_nextwhite;    /* assume no & deception */
5330 #endif
5331
5332                     /* Two barewords in a row may indicate method call. */
5333
5334                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') &&
5335                         (tmp = intuit_method(s, gv, cv)))
5336                         return REPORT(tmp);
5337
5338                     /* If not a declared subroutine, it's an indirect object. */
5339                     /* (But it's an indir obj regardless for sort.) */
5340                     /* Also, if "_" follows a filetest operator, it's a bareword */
5341
5342                     if (
5343                         ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
5344                          ((!gv || !cv) &&
5345                         (PL_last_lop_op != OP_MAPSTART &&
5346                          PL_last_lop_op != OP_GREPSTART))))
5347                        || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
5348                             && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
5349                        )
5350                     {
5351                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
5352                         goto bareword;
5353                     }
5354                 }
5355
5356                 PL_expect = XOPERATOR;
5357 #ifdef PERL_MAD
5358                 if (isSPACE(*s))
5359                     s = SKIPSPACE2(s,nextPL_nextwhite);
5360                 PL_nextwhite = nextPL_nextwhite;
5361 #else
5362                 s = skipspace(s);
5363 #endif
5364
5365                 /* Is this a word before a => operator? */
5366                 if (*s == '=' && s[1] == '>' && !pkgname) {
5367                     CLINE;
5368                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
5369                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
5370                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
5371                     TERM(WORD);
5372                 }
5373
5374                 /* If followed by a paren, it's certainly a subroutine. */
5375                 if (*s == '(') {
5376                     CLINE;
5377                     if (cv) {
5378                         d = s + 1;
5379                         while (SPACE_OR_TAB(*d))
5380                             d++;
5381                         if (*d == ')' && (sv = gv_const_sv(gv))) {
5382                             s = d + 1;
5383 #ifdef PERL_MAD
5384                             if (PL_madskills) {
5385                                 char *par = SvPVX(PL_linestr) + PL_realtokenstart;
5386                                 sv_catpvn(PL_thistoken, par, s - par);
5387                                 if (PL_nextwhite) {
5388                                     sv_free(PL_nextwhite);
5389                                     PL_nextwhite = 0;
5390                                 }
5391                             }
5392 #endif
5393                             goto its_constant;
5394                         }
5395                     }
5396 #ifdef PERL_MAD
5397                     if (PL_madskills) {
5398                         PL_nextwhite = PL_thiswhite;
5399                         PL_thiswhite = 0;
5400                     }
5401                     start_force(PL_curforce);
5402 #endif
5403                     NEXTVAL_NEXTTOKE.opval = yylval.opval;
5404                     PL_expect = XOPERATOR;
5405 #ifdef PERL_MAD
5406                     if (PL_madskills) {
5407                         PL_nextwhite = nextPL_nextwhite;
5408                         curmad('X', PL_thistoken);
5409                         PL_thistoken = newSVpvs("");
5410                     }
5411 #endif
5412                     force_next(WORD);
5413                     yylval.ival = 0;
5414                     TOKEN('&');
5415                 }
5416
5417                 /* If followed by var or block, call it a method (unless sub) */
5418
5419                 if ((*s == '$' || *s == '{') && (!gv || !cv)) {
5420                     PL_last_lop = PL_oldbufptr;
5421                     PL_last_lop_op = OP_METHOD;
5422                     PREBLOCK(METHOD);
5423                 }
5424
5425                 /* If followed by a bareword, see if it looks like indir obj. */
5426
5427                 if (!orig_keyword
5428                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
5429                         && (tmp = intuit_method(s, gv, cv)))
5430                     return REPORT(tmp);
5431
5432                 /* Not a method, so call it a subroutine (if defined) */
5433
5434                 if (cv) {
5435                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
5436                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5437                                 "Ambiguous use of -%s resolved as -&%s()",
5438                                 PL_tokenbuf, PL_tokenbuf);
5439                     /* Check for a constant sub */
5440                     if ((sv = gv_const_sv(gv))) {
5441                   its_constant:
5442                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
5443                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc_simple(sv);
5444                         yylval.opval->op_private = 0;
5445                         TOKEN(WORD);
5446                     }
5447
5448                     /* Resolve to GV now. */
5449                     if (SvTYPE(gv) != SVt_PVGV) {
5450                         gv = gv_fetchpv(PL_tokenbuf, 0, SVt_PVCV);
5451                         assert (SvTYPE(gv) == SVt_PVGV);
5452                         /* cv must have been some sort of placeholder, so
5453                            now needs replacing with a real code reference.  */
5454                         cv = GvCV(gv);
5455                     }
5456
5457                     op_free(yylval.opval);
5458                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5459                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5460                     PL_last_lop = PL_oldbufptr;
5461                     PL_last_lop_op = OP_ENTERSUB;
5462                     /* Is there a prototype? */
5463                     if (
5464 #ifdef PERL_MAD
5465                         cv &&
5466 #endif
5467                         SvPOK(cv))
5468                     {
5469                         STRLEN protolen;
5470                         const char *proto = SvPV_const((SV*)cv, protolen);
5471                         if (!protolen)
5472                             TERM(FUNC0SUB);
5473                         if ((*proto == '$' || *proto == '_') && proto[1] == '\0')
5474                             OPERATOR(UNIOPSUB);
5475                         while (*proto == ';')
5476                             proto++;
5477                         if (*proto == '&' && *s == '{') {
5478                             sv_setpv(PL_subname,
5479                                      (const char *)
5480                                      (PL_curstash ?
5481                                       "__ANON__" : "__ANON__::__ANON__"));
5482                             PREBLOCK(LSTOPSUB);
5483                         }
5484                     }
5485 #ifdef PERL_MAD
5486                     {
5487                         if (PL_madskills) {
5488                             PL_nextwhite = PL_thiswhite;
5489                             PL_thiswhite = 0;
5490                         }
5491                         start_force(PL_curforce);
5492                         NEXTVAL_NEXTTOKE.opval = yylval.opval;
5493                         PL_expect = XTERM;
5494                         if (PL_madskills) {
5495                             PL_nextwhite = nextPL_nextwhite;
5496                             curmad('X', PL_thistoken);
5497                             PL_thistoken = newSVpvs("");
5498                         }
5499                         force_next(WORD);
5500                         TOKEN(NOAMP);
5501                     }
5502                 }
5503
5504                 /* Guess harder when madskills require "best effort". */
5505                 if (PL_madskills && (!gv || !GvCVu(gv))) {
5506                     int probable_sub = 0;
5507                     if (strchr("\"'`$@%0123456789!*+{[<", *s))
5508                         probable_sub = 1;
5509                     else if (isALPHA(*s)) {
5510                         char tmpbuf[1024];
5511                         STRLEN tmplen;
5512                         d = s;
5513                         d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen);
5514                         if (!keyword(tmpbuf, tmplen, 0))
5515                             probable_sub = 1;
5516                         else {
5517                             while (d < PL_bufend && isSPACE(*d))
5518                                 d++;
5519                             if (*d == '=' && d[1] == '>')
5520                                 probable_sub = 1;
5521                         }
5522                     }
5523                     if (probable_sub) {
5524                         gv = gv_fetchpv(PL_tokenbuf, TRUE, SVt_PVCV);
5525                         op_free(yylval.opval);
5526                         yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
5527                         yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
5528                         PL_last_lop = PL_oldbufptr;
5529                         PL_last_lop_op = OP_ENTERSUB;
5530                         PL_nextwhite = PL_thiswhite;
5531                         PL_thiswhite = 0;
5532                         start_force(PL_curforce);
5533                         NEXTVAL_NEXTTOKE.opval = yylval.opval;
5534                         PL_expect = XTERM;
5535                         PL_nextwhite = nextPL_nextwhite;
5536                         curmad('X', PL_thistoken);
5537                         PL_thistoken = newSVpvs("");
5538                         force_next(WORD);
5539                         TOKEN(NOAMP);
5540                     }
5541 #else
5542                     NEXTVAL_NEXTTOKE.opval = yylval.opval;
5543                     PL_expect = XTERM;
5544                     force_next(WORD);
5545                     TOKEN(NOAMP);
5546 #endif
5547                 }
5548
5549                 /* Call it a bare word */
5550
5551                 if (PL_hints & HINT_STRICT_SUBS)
5552                     yylval.opval->op_private |= OPpCONST_STRICT;
5553                 else {
5554                 bareword:
5555                     if (lastchar != '-') {
5556                         if (ckWARN(WARN_RESERVED)) {
5557                             d = PL_tokenbuf;
5558                             while (isLOWER(*d))
5559                                 d++;
5560                             if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
5561                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
5562                                        PL_tokenbuf);
5563                         }
5564                     }
5565                 }
5566
5567             safe_bareword:
5568                 if ((lastchar == '*' || lastchar == '%' || lastchar == '&')
5569                     && ckWARN_d(WARN_AMBIGUOUS)) {
5570                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5571                         "Operator or semicolon missing before %c%s",
5572                         lastchar, PL_tokenbuf);
5573                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5574                         "Ambiguous use of %c resolved as operator %c",
5575                         lastchar, lastchar);
5576                 }
5577                 TOKEN(WORD);
5578             }
5579
5580         case KEY___FILE__:
5581             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5582                                         newSVpv(CopFILE(PL_curcop),0));
5583             TERM(THING);
5584
5585         case KEY___LINE__:
5586             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5587                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
5588             TERM(THING);
5589
5590         case KEY___PACKAGE__:
5591             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
5592                                         (PL_curstash
5593                                          ? newSVhek(HvNAME_HEK(PL_curstash))
5594                                          : &PL_sv_undef));
5595             TERM(THING);
5596
5597         case KEY___DATA__:
5598         case KEY___END__: {
5599             GV *gv;
5600             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
5601                 const char *pname = "main";
5602                 if (PL_tokenbuf[2] == 'D')
5603                     pname = HvNAME_get(PL_curstash ? PL_curstash : PL_defstash);
5604                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), GV_ADD,
5605                                 SVt_PVIO);
5606                 GvMULTI_on(gv);
5607                 if (!GvIO(gv))
5608                     GvIOp(gv) = newIO();
5609                 IoIFP(GvIOp(gv)) = PL_rsfp;
5610 #if defined(HAS_FCNTL) && defined(F_SETFD)
5611                 {
5612                     const int fd = PerlIO_fileno(PL_rsfp);
5613                     fcntl(fd,F_SETFD,fd >= 3);
5614                 }
5615 #endif
5616                 /* Mark this internal pseudo-handle as clean */
5617                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
5618                 if (PL_preprocess)
5619                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
5620                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
5621                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
5622                 else
5623                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
5624 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
5625                 /* if the script was opened in binmode, we need to revert
5626                  * it to text mode for compatibility; but only iff it has CRs
5627                  * XXX this is a questionable hack at best. */
5628                 if (PL_bufend-PL_bufptr > 2
5629                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
5630                 {
5631                     Off_t loc = 0;
5632                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
5633                         loc = PerlIO_tell(PL_rsfp);
5634                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
5635                     }
5636 #ifdef NETWARE
5637                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
5638 #else
5639                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
5640 #endif  /* NETWARE */
5641 #ifdef PERLIO_IS_STDIO /* really? */
5642 #  if defined(__BORLANDC__)
5643                         /* XXX see note in do_binmode() */
5644                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
5645 #  endif
5646 #endif
5647                         if (loc > 0)
5648                             PerlIO_seek(PL_rsfp, loc, 0);
5649                     }
5650                 }
5651 #endif
5652 #ifdef PERLIO_LAYERS
5653                 if (!IN_BYTES) {
5654                     if (UTF)
5655                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
5656                     else if (PL_encoding) {
5657                         SV *name;
5658                         dSP;
5659                         ENTER;
5660                         SAVETMPS;
5661                         PUSHMARK(sp);
5662                         EXTEND(SP, 1);
5663                         XPUSHs(PL_encoding);
5664                         PUTBACK;
5665                         call_method("name", G_SCALAR);
5666                         SPAGAIN;
5667                         name = POPs;
5668                         PUTBACK;
5669                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
5670                                             Perl_form(aTHX_ ":encoding(%"SVf")",
5671                                                       SVfARG(name)));
5672                         FREETMPS;
5673                         LEAVE;
5674                     }
5675                 }
5676 #endif
5677 #ifdef PERL_MAD
5678                 if (PL_madskills) {
5679                     if (PL_realtokenstart >= 0) {
5680                         char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
5681                         if (!PL_endwhite)
5682                             PL_endwhite = newSVpvs("");
5683                         sv_catsv(PL_endwhite, PL_thiswhite);
5684                         PL_thiswhite = 0;
5685                         sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart);
5686                         PL_realtokenstart = -1;
5687                     }
5688                     while ((s = filter_gets(PL_endwhite, PL_rsfp,
5689                                  SvCUR(PL_endwhite))) != Nullch) ;
5690                 }
5691 #endif
5692                 PL_rsfp = NULL;
5693             }
5694             goto fake_eof;
5695         }
5696
5697         case KEY_AUTOLOAD:
5698         case KEY_DESTROY:
5699         case KEY_BEGIN:
5700         case KEY_UNITCHECK:
5701         case KEY_CHECK:
5702         case KEY_INIT:
5703         case KEY_END:
5704             if (PL_expect == XSTATE) {
5705                 s = PL_bufptr;
5706                 goto really_sub;
5707             }
5708             goto just_a_word;
5709
5710         case KEY_CORE:
5711             if (*s == ':' && s[1] == ':') {
5712                 s += 2;
5713                 d = s;
5714                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
5715                 if (!(tmp = keyword(PL_tokenbuf, len, 0)))
5716                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
5717                 if (tmp < 0)
5718                     tmp = -tmp;
5719                 else if (tmp == KEY_require || tmp == KEY_do)
5720                     /* that's a way to remember we saw "CORE::" */
5721                     orig_keyword = tmp;
5722                 goto reserved_word;
5723             }
5724             goto just_a_word;
5725
5726         case KEY_abs:
5727             UNI(OP_ABS);
5728
5729         case KEY_alarm:
5730             UNI(OP_ALARM);
5731
5732         case KEY_accept:
5733             LOP(OP_ACCEPT,XTERM);
5734
5735         case KEY_and:
5736             OPERATOR(ANDOP);
5737
5738         case KEY_atan2:
5739             LOP(OP_ATAN2,XTERM);
5740
5741         case KEY_bind:
5742             LOP(OP_BIND,XTERM);
5743
5744         case KEY_binmode:
5745             LOP(OP_BINMODE,XTERM);
5746
5747         case KEY_bless:
5748             LOP(OP_BLESS,XTERM);
5749
5750         case KEY_break:
5751             FUN0(OP_BREAK);
5752
5753         case KEY_chop:
5754             UNI(OP_CHOP);
5755
5756         case KEY_continue:
5757             /* When 'use switch' is in effect, continue has a dual
5758                life as a control operator. */
5759             {
5760                 if (!FEATURE_IS_ENABLED("switch"))
5761                     PREBLOCK(CONTINUE);
5762                 else {
5763                     /* We have to disambiguate the two senses of
5764                       "continue". If the next token is a '{' then
5765                       treat it as the start of a continue block;
5766                       otherwise treat it as a control operator.
5767                      */
5768                     s = skipspace(s);
5769                     if (*s == '{')
5770             PREBLOCK(CONTINUE);
5771                     else
5772                         FUN0(OP_CONTINUE);
5773                 }
5774             }
5775
5776         case KEY_chdir:
5777             /* may use HOME */
5778             (void)gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV);
5779             UNI(OP_CHDIR);
5780
5781         case KEY_close:
5782             UNI(OP_CLOSE);
5783
5784         case KEY_closedir:
5785             UNI(OP_CLOSEDIR);
5786
5787         case KEY_cmp:
5788             Eop(OP_SCMP);
5789
5790         case KEY_caller:
5791             UNI(OP_CALLER);
5792
5793         case KEY_crypt:
5794 #ifdef FCRYPT
5795             if (!PL_cryptseen) {
5796                 PL_cryptseen = TRUE;
5797                 init_des();
5798             }
5799 #endif
5800             LOP(OP_CRYPT,XTERM);
5801
5802         case KEY_chmod:
5803             LOP(OP_CHMOD,XTERM);
5804
5805         case KEY_chown:
5806             LOP(OP_CHOWN,XTERM);
5807
5808         case KEY_connect:
5809             LOP(OP_CONNECT,XTERM);
5810
5811         case KEY_chr:
5812             UNI(OP_CHR);
5813
5814         case KEY_cos:
5815             UNI(OP_COS);
5816
5817         case KEY_chroot:
5818             UNI(OP_CHROOT);
5819
5820         case KEY_default:
5821             PREBLOCK(DEFAULT);
5822
5823         case KEY_do:
5824             s = SKIPSPACE1(s);
5825             if (*s == '{')
5826                 PRETERMBLOCK(DO);
5827             if (*s != '\'')
5828                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
5829             if (orig_keyword == KEY_do) {
5830                 orig_keyword = 0;
5831                 yylval.ival = 1;
5832             }
5833             else
5834                 yylval.ival = 0;
5835             OPERATOR(DO);
5836
5837         case KEY_die:
5838             PL_hints |= HINT_BLOCK_SCOPE;
5839             LOP(OP_DIE,XTERM);
5840
5841         case KEY_defined:
5842             UNI(OP_DEFINED);
5843
5844         case KEY_delete:
5845             UNI(OP_DELETE);
5846
5847         case KEY_dbmopen:
5848             gv_fetchpvs("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
5849             LOP(OP_DBMOPEN,XTERM);
5850
5851         case KEY_dbmclose:
5852             UNI(OP_DBMCLOSE);
5853
5854         case KEY_dump:
5855             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5856             LOOPX(OP_DUMP);
5857
5858         case KEY_else:
5859             PREBLOCK(ELSE);
5860
5861         case KEY_elsif:
5862             yylval.ival = CopLINE(PL_curcop);
5863             OPERATOR(ELSIF);
5864
5865         case KEY_eq:
5866             Eop(OP_SEQ);
5867
5868         case KEY_exists:
5869             UNI(OP_EXISTS);
5870
5871         case KEY_exit:
5872             if (PL_madskills)
5873                 UNI(OP_INT);
5874             UNI(OP_EXIT);
5875
5876         case KEY_eval:
5877             s = SKIPSPACE1(s);
5878             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
5879             UNIBRACK(OP_ENTEREVAL);
5880
5881         case KEY_eof:
5882             UNI(OP_EOF);
5883
5884         case KEY_err:
5885             OPERATOR(DOROP);
5886
5887         case KEY_exp:
5888             UNI(OP_EXP);
5889
5890         case KEY_each:
5891             UNI(OP_EACH);
5892
5893         case KEY_exec:
5894             set_csh();
5895             LOP(OP_EXEC,XREF);
5896
5897         case KEY_endhostent:
5898             FUN0(OP_EHOSTENT);
5899
5900         case KEY_endnetent:
5901             FUN0(OP_ENETENT);
5902
5903         case KEY_endservent:
5904             FUN0(OP_ESERVENT);
5905
5906         case KEY_endprotoent:
5907             FUN0(OP_EPROTOENT);
5908
5909         case KEY_endpwent:
5910             FUN0(OP_EPWENT);
5911
5912         case KEY_endgrent:
5913             FUN0(OP_EGRENT);
5914
5915         case KEY_for:
5916         case KEY_foreach:
5917             yylval.ival = CopLINE(PL_curcop);
5918             s = SKIPSPACE1(s);
5919             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
5920                 char *p = s;
5921 #ifdef PERL_MAD
5922                 int soff = s - SvPVX(PL_linestr); /* for skipspace realloc */
5923 #endif
5924
5925                 if ((PL_bufend - p) >= 3 &&
5926                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
5927                     p += 2;
5928                 else if ((PL_bufend - p) >= 4 &&
5929                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
5930                     p += 3;
5931                 p = PEEKSPACE(p);
5932                 if (isIDFIRST_lazy_if(p,UTF)) {
5933                     p = scan_ident(p, PL_bufend,
5934                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
5935                     p = PEEKSPACE(p);
5936                 }
5937                 if (*p != '$')
5938                     Perl_croak(aTHX_ "Missing $ on loop variable");
5939 #ifdef PERL_MAD
5940                 s = SvPVX(PL_linestr) + soff;
5941 #endif
5942             }
5943             OPERATOR(FOR);
5944
5945         case KEY_formline:
5946             LOP(OP_FORMLINE,XTERM);
5947
5948         case KEY_fork:
5949             FUN0(OP_FORK);
5950
5951         case KEY_fcntl:
5952             LOP(OP_FCNTL,XTERM);
5953
5954         case KEY_fileno:
5955             UNI(OP_FILENO);
5956
5957         case KEY_flock:
5958             LOP(OP_FLOCK,XTERM);
5959
5960         case KEY_gt:
5961             Rop(OP_SGT);
5962
5963         case KEY_ge:
5964             Rop(OP_SGE);
5965
5966         case KEY_grep:
5967             LOP(OP_GREPSTART, XREF);
5968
5969         case KEY_goto:
5970             s = force_word(s,WORD,TRUE,FALSE,FALSE);
5971             LOOPX(OP_GOTO);
5972
5973         case KEY_gmtime:
5974             UNI(OP_GMTIME);
5975
5976         case KEY_getc:
5977             UNIDOR(OP_GETC);
5978
5979         case KEY_getppid:
5980             FUN0(OP_GETPPID);
5981
5982         case KEY_getpgrp:
5983             UNI(OP_GETPGRP);
5984
5985         case KEY_getpriority:
5986             LOP(OP_GETPRIORITY,XTERM);
5987
5988         case KEY_getprotobyname:
5989             UNI(OP_GPBYNAME);
5990
5991         case KEY_getprotobynumber:
5992             LOP(OP_GPBYNUMBER,XTERM);
5993
5994         case KEY_getprotoent:
5995             FUN0(OP_GPROTOENT);
5996
5997         case KEY_getpwent:
5998             FUN0(OP_GPWENT);
5999
6000         case KEY_getpwnam:
6001             UNI(OP_GPWNAM);
6002
6003         case KEY_getpwuid:
6004             UNI(OP_GPWUID);
6005
6006         case KEY_getpeername:
6007             UNI(OP_GETPEERNAME);
6008
6009         case KEY_gethostbyname:
6010             UNI(OP_GHBYNAME);
6011
6012         case KEY_gethostbyaddr:
6013             LOP(OP_GHBYADDR,XTERM);
6014
6015         case KEY_gethostent:
6016             FUN0(OP_GHOSTENT);
6017
6018         case KEY_getnetbyname:
6019             UNI(OP_GNBYNAME);
6020
6021         case KEY_getnetbyaddr:
6022             LOP(OP_GNBYADDR,XTERM);
6023
6024         case KEY_getnetent:
6025             FUN0(OP_GNETENT);
6026
6027         case KEY_getservbyname:
6028             LOP(OP_GSBYNAME,XTERM);
6029
6030         case KEY_getservbyport:
6031             LOP(OP_GSBYPORT,XTERM);
6032
6033         case KEY_getservent:
6034             FUN0(OP_GSERVENT);
6035
6036         case KEY_getsockname:
6037             UNI(OP_GETSOCKNAME);
6038
6039         case KEY_getsockopt:
6040             LOP(OP_GSOCKOPT,XTERM);
6041
6042         case KEY_getgrent:
6043             FUN0(OP_GGRENT);
6044
6045         case KEY_getgrnam:
6046             UNI(OP_GGRNAM);
6047
6048         case KEY_getgrgid:
6049             UNI(OP_GGRGID);
6050
6051         case KEY_getlogin:
6052             FUN0(OP_GETLOGIN);
6053
6054         case KEY_given:
6055             yylval.ival = CopLINE(PL_curcop);
6056             OPERATOR(GIVEN);
6057
6058         case KEY_glob:
6059             set_csh();
6060             LOP(OP_GLOB,XTERM);
6061
6062         case KEY_hex:
6063             UNI(OP_HEX);
6064
6065         case KEY_if:
6066             yylval.ival = CopLINE(PL_curcop);
6067             OPERATOR(IF);
6068
6069         case KEY_index:
6070             LOP(OP_INDEX,XTERM);
6071
6072         case KEY_int:
6073             UNI(OP_INT);
6074
6075         case KEY_ioctl:
6076             LOP(OP_IOCTL,XTERM);
6077
6078         case KEY_join:
6079             LOP(OP_JOIN,XTERM);
6080
6081         case KEY_keys:
6082             UNI(OP_KEYS);
6083
6084         case KEY_kill:
6085             LOP(OP_KILL,XTERM);
6086
6087         case KEY_last:
6088             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6089             LOOPX(OP_LAST);
6090
6091         case KEY_lc:
6092             UNI(OP_LC);
6093
6094         case KEY_lcfirst:
6095             UNI(OP_LCFIRST);
6096
6097         case KEY_local:
6098             yylval.ival = 0;
6099             OPERATOR(LOCAL);
6100
6101         case KEY_length:
6102             UNI(OP_LENGTH);
6103
6104         case KEY_lt:
6105             Rop(OP_SLT);
6106
6107         case KEY_le:
6108             Rop(OP_SLE);
6109
6110         case KEY_localtime:
6111             UNI(OP_LOCALTIME);
6112
6113         case KEY_log:
6114             UNI(OP_LOG);
6115
6116         case KEY_link:
6117             LOP(OP_LINK,XTERM);
6118
6119         case KEY_listen:
6120             LOP(OP_LISTEN,XTERM);
6121
6122         case KEY_lock:
6123             UNI(OP_LOCK);
6124
6125         case KEY_lstat:
6126             UNI(OP_LSTAT);
6127
6128         case KEY_m:
6129             s = scan_pat(s,OP_MATCH);
6130             TERM(sublex_start());
6131
6132         case KEY_map:
6133             LOP(OP_MAPSTART, XREF);
6134
6135         case KEY_mkdir:
6136             LOP(OP_MKDIR,XTERM);
6137
6138         case KEY_msgctl:
6139             LOP(OP_MSGCTL,XTERM);
6140
6141         case KEY_msgget:
6142             LOP(OP_MSGGET,XTERM);
6143
6144         case KEY_msgrcv:
6145             LOP(OP_MSGRCV,XTERM);
6146
6147         case KEY_msgsnd:
6148             LOP(OP_MSGSND,XTERM);
6149
6150         case KEY_our:
6151         case KEY_my:
6152         case KEY_state:
6153             PL_in_my = tmp;
6154             s = SKIPSPACE1(s);
6155             if (isIDFIRST_lazy_if(s,UTF)) {
6156 #ifdef PERL_MAD
6157                 char* start = s;
6158 #endif
6159                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
6160                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
6161                     goto really_sub;
6162                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
6163                 if (!PL_in_my_stash) {
6164                     char tmpbuf[1024];
6165                     PL_bufptr = s;
6166                     my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf);
6167                     yyerror(tmpbuf);
6168                 }
6169 #ifdef PERL_MAD
6170                 if (PL_madskills) {     /* just add type to declarator token */
6171                     sv_catsv(PL_thistoken, PL_nextwhite);
6172                     PL_nextwhite = 0;
6173                     sv_catpvn(PL_thistoken, start, s - start);
6174                 }
6175 #endif
6176             }
6177             yylval.ival = 1;
6178             OPERATOR(MY);
6179
6180         case KEY_next:
6181             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6182             LOOPX(OP_NEXT);
6183
6184         case KEY_ne:
6185             Eop(OP_SNE);
6186
6187         case KEY_no:
6188             s = tokenize_use(0, s);
6189             OPERATOR(USE);
6190
6191         case KEY_not:
6192             if (*s == '(' || (s = SKIPSPACE1(s), *s == '('))
6193                 FUN1(OP_NOT);
6194             else
6195                 OPERATOR(NOTOP);
6196
6197         case KEY_open:
6198             s = SKIPSPACE1(s);
6199             if (isIDFIRST_lazy_if(s,UTF)) {
6200                 const char *t;
6201                 for (d = s; isALNUM_lazy_if(d,UTF);)
6202                     d++;
6203                 for (t=d; isSPACE(*t);)
6204                     t++;
6205                 if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
6206                     /* [perl #16184] */
6207                     && !(t[0] == '=' && t[1] == '>')
6208                 ) {
6209                     int parms_len = (int)(d-s);
6210                     Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
6211                            "Precedence problem: open %.*s should be open(%.*s)",
6212                             parms_len, s, parms_len, s);
6213                 }
6214             }
6215             LOP(OP_OPEN,XTERM);
6216
6217         case KEY_or:
6218             yylval.ival = OP_OR;
6219             OPERATOR(OROP);
6220
6221         case KEY_ord:
6222             UNI(OP_ORD);
6223
6224         case KEY_oct:
6225             UNI(OP_OCT);
6226
6227         case KEY_opendir:
6228             LOP(OP_OPEN_DIR,XTERM);
6229
6230         case KEY_print:
6231             checkcomma(s,PL_tokenbuf,"filehandle");
6232             LOP(OP_PRINT,XREF);
6233
6234         case KEY_printf:
6235             checkcomma(s,PL_tokenbuf,"filehandle");
6236             LOP(OP_PRTF,XREF);
6237
6238         case KEY_prototype:
6239             UNI(OP_PROTOTYPE);
6240
6241         case KEY_push:
6242             LOP(OP_PUSH,XTERM);
6243
6244         case KEY_pop:
6245             UNIDOR(OP_POP);
6246
6247         case KEY_pos:
6248             UNIDOR(OP_POS);
6249
6250         case KEY_pack:
6251             LOP(OP_PACK,XTERM);
6252
6253         case KEY_package:
6254             s = force_word(s,WORD,FALSE,TRUE,FALSE);
6255             OPERATOR(PACKAGE);
6256
6257         case KEY_pipe:
6258             LOP(OP_PIPE_OP,XTERM);
6259
6260         case KEY_q:
6261             s = scan_str(s,!!PL_madskills,FALSE);
6262             if (!s)
6263                 missingterm(NULL);
6264             yylval.ival = OP_CONST;
6265             TERM(sublex_start());
6266
6267         case KEY_quotemeta:
6268             UNI(OP_QUOTEMETA);
6269
6270         case KEY_qw:
6271             s = scan_str(s,!!PL_madskills,FALSE);
6272             if (!s)
6273                 missingterm(NULL);
6274             PL_expect = XOPERATOR;
6275             force_next(')');
6276             if (SvCUR(PL_lex_stuff)) {
6277                 OP *words = NULL;
6278                 int warned = 0;
6279                 d = SvPV_force(PL_lex_stuff, len);
6280                 while (len) {
6281                     for (; isSPACE(*d) && len; --len, ++d)
6282                         /**/;
6283                     if (len) {
6284                         SV *sv;
6285                         const char *b = d;
6286                         if (!warned && ckWARN(WARN_QW)) {
6287                             for (; !isSPACE(*d) && len; --len, ++d) {
6288                                 if (*d == ',') {
6289                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6290                                         "Possible attempt to separate words with commas");
6291                                     ++warned;
6292                                 }
6293                                 else if (*d == '#') {
6294                                     Perl_warner(aTHX_ packWARN(WARN_QW),
6295                                         "Possible attempt to put comments in qw() list");
6296                                     ++warned;
6297                                 }
6298                             }
6299                         }
6300                         else {
6301                             for (; !isSPACE(*d) && len; --len, ++d)
6302                                 /**/;
6303                         }
6304                         sv = newSVpvn(b, d-b);
6305                         if (DO_UTF8(PL_lex_stuff))
6306                             SvUTF8_on(sv);
6307                         words = append_elem(OP_LIST, words,
6308                                             newSVOP(OP_CONST, 0, tokeq(sv)));
6309                     }
6310                 }
6311                 if (words) {
6312                     start_force(PL_curforce);
6313                     NEXTVAL_NEXTTOKE.opval = words;
6314                     force_next(THING);
6315                 }
6316             }
6317             if (PL_lex_stuff) {
6318                 SvREFCNT_dec(PL_lex_stuff);
6319                 PL_lex_stuff = NULL;
6320             }
6321             PL_expect = XTERM;
6322             TOKEN('(');
6323
6324         case KEY_qq:
6325             s = scan_str(s,!!PL_madskills,FALSE);
6326             if (!s)
6327                 missingterm(NULL);
6328             yylval.ival = OP_STRINGIFY;
6329             if (SvIVX(PL_lex_stuff) == '\'')
6330                 SvIV_set(PL_lex_stuff, 0);      /* qq'$foo' should intepolate */
6331             TERM(sublex_start());
6332
6333         case KEY_qr:
6334             s = scan_pat(s,OP_QR);
6335             TERM(sublex_start());
6336
6337         case KEY_qx:
6338             s = scan_str(s,!!PL_madskills,FALSE);
6339             if (!s)
6340                 missingterm(NULL);
6341             readpipe_override();
6342             TERM(sublex_start());
6343
6344         case KEY_return:
6345             OLDLOP(OP_RETURN);
6346
6347         case KEY_require:
6348             s = SKIPSPACE1(s);
6349             if (isDIGIT(*s)) {
6350                 s = force_version(s, FALSE);
6351             }
6352             else if (*s != 'v' || !isDIGIT(s[1])
6353                     || (s = force_version(s, TRUE), *s == 'v'))
6354             {
6355                 *PL_tokenbuf = '\0';
6356                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
6357                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
6358                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
6359                 else if (*s == '<')
6360                     yyerror("<> should be quotes");
6361             }
6362             if (orig_keyword == KEY_require) {
6363                 orig_keyword = 0;
6364                 yylval.ival = 1;
6365             }
6366             else
6367                 yylval.ival = 0;
6368             PL_expect = XTERM;
6369             PL_bufptr = s;
6370             PL_last_uni = PL_oldbufptr;
6371             PL_last_lop_op = OP_REQUIRE;
6372             s = skipspace(s);
6373             return REPORT( (int)REQUIRE );
6374
6375         case KEY_reset:
6376             UNI(OP_RESET);
6377
6378         case KEY_redo:
6379             s = force_word(s,WORD,TRUE,FALSE,FALSE);
6380             LOOPX(OP_REDO);
6381
6382         case KEY_rename:
6383             LOP(OP_RENAME,XTERM);
6384
6385         case KEY_rand:
6386             UNI(OP_RAND);
6387
6388         case KEY_rmdir:
6389             UNI(OP_RMDIR);
6390
6391         case KEY_rindex:
6392             LOP(OP_RINDEX,XTERM);
6393
6394         case KEY_read:
6395             LOP(OP_READ,XTERM);
6396
6397         case KEY_readdir:
6398             UNI(OP_READDIR);
6399
6400         case KEY_readline:
6401             set_csh();
6402             UNIDOR(OP_READLINE);
6403
6404         case KEY_readpipe:
6405             set_csh();
6406             UNI(OP_BACKTICK);
6407
6408         case KEY_rewinddir:
6409             UNI(OP_REWINDDIR);
6410
6411         case KEY_recv:
6412             LOP(OP_RECV,XTERM);
6413
6414         case KEY_reverse:
6415             LOP(OP_REVERSE,XTERM);
6416
6417         case KEY_readlink:
6418             UNIDOR(OP_READLINK);
6419
6420         case KEY_ref:
6421             UNI(OP_REF);
6422
6423         case KEY_s:
6424             s = scan_subst(s);
6425             if (yylval.opval)
6426                 TERM(sublex_start());
6427             else
6428                 TOKEN(1);       /* force error */
6429
6430         case KEY_say:
6431             checkcomma(s,PL_tokenbuf,"filehandle");
6432             LOP(OP_SAY,XREF);
6433
6434         case KEY_chomp:
6435             UNI(OP_CHOMP);
6436
6437         case KEY_scalar:
6438             UNI(OP_SCALAR);
6439
6440         case KEY_select:
6441             LOP(OP_SELECT,XTERM);
6442
6443         case KEY_seek:
6444             LOP(OP_SEEK,XTERM);
6445
6446         case KEY_semctl:
6447             LOP(OP_SEMCTL,XTERM);
6448
6449         case KEY_semget:
6450             LOP(OP_SEMGET,XTERM);
6451
6452         case KEY_semop:
6453             LOP(OP_SEMOP,XTERM);
6454
6455         case KEY_send:
6456             LOP(OP_SEND,XTERM);
6457
6458         case KEY_setpgrp:
6459             LOP(OP_SETPGRP,XTERM);
6460
6461         case KEY_setpriority:
6462             LOP(OP_SETPRIORITY,XTERM);
6463
6464         case KEY_sethostent:
6465             UNI(OP_SHOSTENT);
6466
6467         case KEY_setnetent:
6468             UNI(OP_SNETENT);
6469
6470         case KEY_setservent:
6471             UNI(OP_SSERVENT);
6472
6473         case KEY_setprotoent:
6474             UNI(OP_SPROTOENT);
6475
6476         case KEY_setpwent:
6477             FUN0(OP_SPWENT);
6478
6479         case KEY_setgrent:
6480             FUN0(OP_SGRENT);
6481
6482         case KEY_seekdir:
6483             LOP(OP_SEEKDIR,XTERM);
6484
6485         case KEY_setsockopt:
6486             LOP(OP_SSOCKOPT,XTERM);
6487
6488         case KEY_shift:
6489             UNIDOR(OP_SHIFT);
6490
6491         case KEY_shmctl:
6492             LOP(OP_SHMCTL,XTERM);
6493
6494         case KEY_shmget:
6495             LOP(OP_SHMGET,XTERM);
6496
6497         case KEY_shmread:
6498             LOP(OP_SHMREAD,XTERM);
6499
6500         case KEY_shmwrite:
6501             LOP(OP_SHMWRITE,XTERM);
6502
6503         case KEY_shutdown:
6504             LOP(OP_SHUTDOWN,XTERM);
6505
6506         case KEY_sin:
6507             UNI(OP_SIN);
6508
6509         case KEY_sleep:
6510             UNI(OP_SLEEP);
6511
6512         case KEY_socket:
6513             LOP(OP_SOCKET,XTERM);
6514
6515         case KEY_socketpair:
6516             LOP(OP_SOCKPAIR,XTERM);
6517
6518         case KEY_sort:
6519             checkcomma(s,PL_tokenbuf,"subroutine name");
6520             s = SKIPSPACE1(s);
6521             if (*s == ';' || *s == ')')         /* probably a close */
6522                 Perl_croak(aTHX_ "sort is now a reserved word");
6523             PL_expect = XTERM;
6524             s = force_word(s,WORD,TRUE,TRUE,FALSE);
6525             LOP(OP_SORT,XREF);
6526
6527         case KEY_split:
6528             LOP(OP_SPLIT,XTERM);
6529
6530         case KEY_sprintf:
6531             LOP(OP_SPRINTF,XTERM);
6532
6533         case KEY_splice:
6534             LOP(OP_SPLICE,XTERM);
6535
6536         case KEY_sqrt:
6537             UNI(OP_SQRT);
6538
6539         case KEY_srand:
6540             UNI(OP_SRAND);
6541
6542         case KEY_stat:
6543             UNI(OP_STAT);
6544
6545         case KEY_study:
6546             UNI(OP_STUDY);
6547
6548         case KEY_substr:
6549             LOP(OP_SUBSTR,XTERM);
6550
6551         case KEY_format:
6552         case KEY_sub:
6553           really_sub:
6554             {
6555                 char tmpbuf[sizeof PL_tokenbuf];
6556                 SSize_t tboffset = 0;
6557                 expectation attrful;
6558                 bool have_name, have_proto;
6559                 const int key = tmp;
6560
6561 #ifdef PERL_MAD
6562                 SV *tmpwhite = 0;
6563
6564                 char *tstart = SvPVX(PL_linestr) + PL_realtokenstart;
6565                 SV *subtoken = newSVpvn(tstart, s - tstart);
6566                 PL_thistoken = 0;
6567
6568                 d = s;
6569                 s = SKIPSPACE2(s,tmpwhite);
6570 #else
6571                 s = skipspace(s);
6572 #endif
6573
6574                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
6575                     (*s == ':' && s[1] == ':'))
6576                 {
6577 #ifdef PERL_MAD
6578                     SV *nametoke;
6579 #endif
6580
6581                     PL_expect = XBLOCK;
6582                     attrful = XATTRBLOCK;
6583                     /* remember buffer pos'n for later force_word */
6584                     tboffset = s - PL_oldbufptr;
6585                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
6586 #ifdef PERL_MAD
6587                     if (PL_madskills)
6588                         nametoke = newSVpvn(s, d - s);
6589 #endif
6590                     if (strchr(tmpbuf, ':'))
6591                         sv_setpv(PL_subname, tmpbuf);
6592                     else {
6593                         sv_setsv(PL_subname,PL_curstname);
6594                         sv_catpvs(PL_subname,"::");
6595                         sv_catpvn(PL_subname,tmpbuf,len);
6596                     }
6597                     have_name = TRUE;
6598
6599 #ifdef PERL_MAD
6600
6601                     start_force(0);
6602                     CURMAD('X', nametoke);
6603                     CURMAD('_', tmpwhite);
6604                     (void) force_word(PL_oldbufptr + tboffset, WORD,
6605                                       FALSE, TRUE, TRUE);
6606
6607                     s = SKIPSPACE2(d,tmpwhite);
6608 #else
6609                     s = skipspace(d);
6610 #endif
6611                 }
6612                 else {
6613                     if (key == KEY_my)
6614                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
6615                     PL_expect = XTERMBLOCK;
6616                     attrful = XATTRTERM;
6617                     sv_setpvn(PL_subname,"?",1);
6618                     have_name = FALSE;
6619                 }
6620
6621                 if (key == KEY_format) {
6622                     if (*s == '=')
6623                         PL_lex_formbrack = PL_lex_brackets + 1;
6624 #ifdef PERL_MAD
6625                     PL_thistoken = subtoken;
6626                     s = d;
6627 #else
6628                     if (have_name)
6629                         (void) force_word(PL_oldbufptr + tboffset, WORD,
6630                                           FALSE, TRUE, TRUE);
6631 #endif
6632                     OPERATOR(FORMAT);
6633                 }
6634
6635                 /* Look for a prototype */
6636                 if (*s == '(') {
6637                     char *p;
6638                     bool bad_proto = FALSE;
6639                     const bool warnsyntax = ckWARN(WARN_SYNTAX);
6640
6641                     s = scan_str(s,!!PL_madskills,FALSE);
6642                     if (!s)
6643                         Perl_croak(aTHX_ "Prototype not terminated");
6644                     /* strip spaces and check for bad characters */
6645                     d = SvPVX(PL_lex_stuff);
6646                     tmp = 0;
6647                     for (p = d; *p; ++p) {
6648                         if (!isSPACE(*p)) {
6649                             d[tmp++] = *p;
6650                             if (warnsyntax && !strchr("$@%*;[]&\\_", *p))
6651                                 bad_proto = TRUE;
6652                         }
6653                     }
6654                     d[tmp] = '\0';
6655                     if (bad_proto)
6656                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6657                                     "Illegal character in prototype for %"SVf" : %s",
6658                                     SVfARG(PL_subname), d);
6659                     SvCUR_set(PL_lex_stuff, tmp);
6660                     have_proto = TRUE;
6661
6662 #ifdef PERL_MAD
6663                     start_force(0);
6664                     CURMAD('q', PL_thisopen);
6665                     CURMAD('_', tmpwhite);
6666                     CURMAD('=', PL_thisstuff);
6667                     CURMAD('Q', PL_thisclose);
6668                     NEXTVAL_NEXTTOKE.opval =
6669                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6670                     PL_lex_stuff = Nullsv;
6671                     force_next(THING);
6672
6673                     s = SKIPSPACE2(s,tmpwhite);
6674 #else
6675                     s = skipspace(s);
6676 #endif
6677                 }
6678                 else
6679                     have_proto = FALSE;
6680
6681                 if (*s == ':' && s[1] != ':')
6682                     PL_expect = attrful;
6683                 else if (*s != '{' && key == KEY_sub) {
6684                     if (!have_name)
6685                         Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
6686                     else if (*s != ';')
6687                         Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname));
6688                 }
6689
6690 #ifdef PERL_MAD
6691                 start_force(0);
6692                 if (tmpwhite) {
6693                     if (PL_madskills)
6694                         curmad('^', newSVpvs(""));
6695                     CURMAD('_', tmpwhite);
6696                 }
6697                 force_next(0);
6698
6699                 PL_thistoken = subtoken;
6700 #else
6701                 if (have_proto) {
6702                     NEXTVAL_NEXTTOKE.opval =
6703                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
6704                     PL_lex_stuff = NULL;
6705                     force_next(THING);
6706                 }
6707 #endif
6708                 if (!have_name) {
6709                     sv_setpv(PL_subname,
6710                              (const char *)
6711                              (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"));
6712                     TOKEN(ANONSUB);
6713                 }
6714 #ifndef PERL_MAD
6715                 (void) force_word(PL_oldbufptr + tboffset, WORD,
6716                                   FALSE, TRUE, TRUE);
6717 #endif
6718                 if (key == KEY_my)
6719                     TOKEN(MYSUB);
6720                 TOKEN(SUB);
6721             }
6722
6723         case KEY_system:
6724             set_csh();
6725             LOP(OP_SYSTEM,XREF);
6726
6727         case KEY_symlink:
6728             LOP(OP_SYMLINK,XTERM);
6729
6730         case KEY_syscall:
6731             LOP(OP_SYSCALL,XTERM);
6732
6733         case KEY_sysopen:
6734             LOP(OP_SYSOPEN,XTERM);
6735
6736         case KEY_sysseek:
6737             LOP(OP_SYSSEEK,XTERM);
6738
6739         case KEY_sysread:
6740             LOP(OP_SYSREAD,XTERM);
6741
6742         case KEY_syswrite:
6743             LOP(OP_SYSWRITE,XTERM);
6744
6745         case KEY_tr:
6746             s = scan_trans(s);
6747             TERM(sublex_start());
6748
6749         case KEY_tell:
6750             UNI(OP_TELL);
6751
6752         case KEY_telldir:
6753             UNI(OP_TELLDIR);
6754
6755         case KEY_tie:
6756             LOP(OP_TIE,XTERM);
6757
6758         case KEY_tied:
6759             UNI(OP_TIED);
6760
6761         case KEY_time:
6762             FUN0(OP_TIME);
6763
6764         case KEY_times:
6765             FUN0(OP_TMS);
6766
6767         case KEY_truncate:
6768             LOP(OP_TRUNCATE,XTERM);
6769
6770         case KEY_uc:
6771             UNI(OP_UC);
6772
6773         case KEY_ucfirst:
6774             UNI(OP_UCFIRST);
6775
6776         case KEY_untie:
6777             UNI(OP_UNTIE);
6778
6779         case KEY_until:
6780             yylval.ival = CopLINE(PL_curcop);
6781             OPERATOR(UNTIL);
6782
6783         case KEY_unless:
6784             yylval.ival = CopLINE(PL_curcop);
6785             OPERATOR(UNLESS);
6786
6787         case KEY_unlink:
6788             LOP(OP_UNLINK,XTERM);
6789
6790         case KEY_undef:
6791             UNIDOR(OP_UNDEF);
6792
6793         case KEY_unpack:
6794             LOP(OP_UNPACK,XTERM);
6795
6796         case KEY_utime:
6797             LOP(OP_UTIME,XTERM);
6798
6799         case KEY_umask:
6800             UNIDOR(OP_UMASK);
6801
6802         case KEY_unshift:
6803             LOP(OP_UNSHIFT,XTERM);
6804
6805         case KEY_use:
6806             s = tokenize_use(1, s);
6807             OPERATOR(USE);
6808
6809         case KEY_values:
6810             UNI(OP_VALUES);
6811
6812         case KEY_vec:
6813             LOP(OP_VEC,XTERM);
6814
6815         case KEY_when:
6816             yylval.ival = CopLINE(PL_curcop);
6817             OPERATOR(WHEN);
6818
6819         case KEY_while:
6820             yylval.ival = CopLINE(PL_curcop);
6821             OPERATOR(WHILE);
6822
6823         case KEY_warn:
6824             PL_hints |= HINT_BLOCK_SCOPE;
6825             LOP(OP_WARN,XTERM);
6826
6827         case KEY_wait:
6828             FUN0(OP_WAIT);
6829
6830         case KEY_waitpid:
6831             LOP(OP_WAITPID,XTERM);
6832
6833         case KEY_wantarray:
6834             FUN0(OP_WANTARRAY);
6835
6836         case KEY_write:
6837 #ifdef EBCDIC
6838         {
6839             char ctl_l[2];
6840             ctl_l[0] = toCTRL('L');
6841             ctl_l[1] = '\0';
6842             gv_fetchpvn_flags(ctl_l, 1, GV_ADD|GV_NOTQUAL, SVt_PV);
6843         }
6844 #else
6845             /* Make sure $^L is defined */
6846             gv_fetchpvs("\f", GV_ADD|GV_NOTQUAL, SVt_PV);
6847 #endif
6848             UNI(OP_ENTERWRITE);
6849
6850         case KEY_x:
6851             if (PL_expect == XOPERATOR)
6852                 Mop(OP_REPEAT);
6853             check_uni();
6854             goto just_a_word;
6855
6856         case KEY_xor:
6857             yylval.ival = OP_XOR;
6858             OPERATOR(OROP);
6859
6860         case KEY_y:
6861             s = scan_trans(s);
6862             TERM(sublex_start());
6863         }
6864     }}
6865 }
6866 #ifdef __SC__
6867 #pragma segment Main
6868 #endif
6869
6870 static int
6871 S_pending_ident(pTHX)
6872 {
6873     dVAR;
6874     register char *d;
6875     PADOFFSET tmp = 0;
6876     /* pit holds the identifier we read and pending_ident is reset */
6877     char pit = PL_pending_ident;
6878     PL_pending_ident = 0;
6879
6880     /* PL_realtokenstart = realtokenend = PL_bufptr - SvPVX(PL_linestr); */
6881     DEBUG_T({ PerlIO_printf(Perl_debug_log,
6882           "### Pending identifier '%s'\n", PL_tokenbuf); });
6883
6884     /* if we're in a my(), we can't allow dynamics here.
6885        $foo'bar has already been turned into $foo::bar, so
6886        just check for colons.
6887
6888        if it's a legal name, the OP is a PADANY.
6889     */
6890     if (PL_in_my) {
6891         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
6892             if (strchr(PL_tokenbuf,':'))
6893                 yyerror(Perl_form(aTHX_ "No package name allowed for "
6894                                   "variable %s in \"our\"",
6895                                   PL_tokenbuf));
6896             tmp = allocmy(PL_tokenbuf);
6897         }
6898         else {
6899             if (strchr(PL_tokenbuf,':'))
6900                 yyerror(Perl_form(aTHX_ PL_no_myglob,
6901                             PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf));
6902
6903             yylval.opval = newOP(OP_PADANY, 0);
6904             yylval.opval->op_targ = allocmy(PL_tokenbuf);
6905             return PRIVATEREF;
6906         }
6907     }
6908
6909     /*
6910        build the ops for accesses to a my() variable.
6911
6912        Deny my($a) or my($b) in a sort block, *if* $a or $b is
6913        then used in a comparison.  This catches most, but not
6914        all cases.  For instance, it catches
6915            sort { my($a); $a <=> $b }
6916        but not
6917            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
6918        (although why you'd do that is anyone's guess).
6919     */
6920
6921     if (!strchr(PL_tokenbuf,':')) {
6922         if (!PL_in_my)
6923             tmp = pad_findmy(PL_tokenbuf);
6924         if (tmp != NOT_IN_PAD) {
6925             /* might be an "our" variable" */
6926             if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
6927                 /* build ops for a bareword */
6928                 HV *  const stash = PAD_COMPNAME_OURSTASH(tmp);
6929                 HEK * const stashname = HvNAME_HEK(stash);
6930                 SV *  const sym = newSVhek(stashname);
6931                 sv_catpvs(sym, "::");
6932                 sv_catpv(sym, PL_tokenbuf+1);
6933                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
6934                 yylval.opval->op_private = OPpCONST_ENTERED;
6935                 gv_fetchsv(sym,
6936                     (PL_in_eval
6937                         ? (GV_ADDMULTI | GV_ADDINEVAL)
6938                         : GV_ADDMULTI
6939                     ),
6940                     ((PL_tokenbuf[0] == '$') ? SVt_PV
6941                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
6942                      : SVt_PVHV));
6943                 return WORD;
6944             }
6945
6946             /* if it's a sort block and they're naming $a or $b */
6947             if (PL_last_lop_op == OP_SORT &&
6948                 PL_tokenbuf[0] == '$' &&
6949                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
6950                 && !PL_tokenbuf[2])
6951             {
6952                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
6953                      d < PL_bufend && *d != '\n';
6954                      d++)
6955                 {
6956                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
6957                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
6958                               PL_tokenbuf);
6959                     }
6960                 }
6961             }
6962
6963             yylval.opval = newOP(OP_PADANY, 0);
6964             yylval.opval->op_targ = tmp;
6965             return PRIVATEREF;
6966         }
6967     }
6968
6969     /*
6970        Whine if they've said @foo in a doublequoted string,
6971        and @foo isn't a variable we can find in the symbol
6972        table.
6973     */
6974     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
6975         GV *gv = gv_fetchpv(PL_tokenbuf+1, 0, SVt_PVAV);
6976         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
6977              && ckWARN(WARN_AMBIGUOUS))
6978         {
6979             /* Downgraded from fatal to warning 20000522 mjd */
6980             Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6981                         "Possible unintended interpolation of %s in string",
6982                          PL_tokenbuf);
6983         }
6984     }
6985
6986     /* build ops for a bareword */
6987     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
6988     yylval.opval->op_private = OPpCONST_ENTERED;
6989     gv_fetchpv(
6990             PL_tokenbuf+1,
6991             /* If the identifier refers to a stash, don't autovivify it.
6992              * Change 24660 had the side effect of causing symbol table
6993              * hashes to always be defined, even if they were freshly
6994              * created and the only reference in the entire program was
6995              * the single statement with the defined %foo::bar:: test.
6996              * It appears that all code in the wild doing this actually
6997              * wants to know whether sub-packages have been loaded, so
6998              * by avoiding auto-vivifying symbol tables, we ensure that
6999              * defined %foo::bar:: continues to be false, and the existing
7000              * tests still give the expected answers, even though what
7001              * they're actually testing has now changed subtly.
7002              */
7003             (*PL_tokenbuf == '%' && *(d = PL_tokenbuf + strlen(PL_tokenbuf) - 1) == ':' && d[-1] == ':'
7004              ? 0
7005              : PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : GV_ADD),
7006             ((PL_tokenbuf[0] == '$') ? SVt_PV
7007              : (PL_tokenbuf[0] == '@') ? SVt_PVAV
7008              : SVt_PVHV));
7009     return WORD;
7010 }
7011
7012 /*
7013  *  The following code was generated by perl_keyword.pl.
7014  */
7015
7016 I32
7017 Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords)
7018 {
7019     dVAR;
7020   switch (len)
7021   {
7022     case 1: /* 5 tokens of length 1 */
7023       switch (name[0])
7024       {
7025         case 'm':
7026           {                                       /* m          */
7027             return KEY_m;
7028           }
7029
7030         case 'q':
7031           {                                       /* q          */
7032             return KEY_q;
7033           }
7034
7035         case 's':
7036           {                                       /* s          */
7037             return KEY_s;
7038           }
7039
7040         case 'x':
7041           {                                       /* x          */
7042             return -KEY_x;
7043           }
7044
7045         case 'y':
7046           {                                       /* y          */
7047             return KEY_y;
7048           }
7049
7050         default:
7051           goto unknown;
7052       }
7053
7054     case 2: /* 18 tokens of length 2 */
7055       switch (name[0])
7056       {
7057         case 'd':
7058           if (name[1] == 'o')
7059           {                                       /* do         */
7060             return KEY_do;
7061           }
7062
7063           goto unknown;
7064
7065         case 'e':
7066           if (name[1] == 'q')
7067           {                                       /* eq         */
7068             return -KEY_eq;
7069           }
7070
7071           goto unknown;
7072
7073         case 'g':
7074           switch (name[1])
7075           {
7076             case 'e':
7077               {                                   /* ge         */
7078                 return -KEY_ge;
7079               }
7080
7081             case 't':
7082               {                                   /* gt         */
7083                 return -KEY_gt;
7084               }
7085
7086             default:
7087               goto unknown;
7088           }
7089
7090         case 'i':
7091           if (name[1] == 'f')
7092           {                                       /* if         */
7093             return KEY_if;
7094           }
7095
7096           goto unknown;
7097
7098         case 'l':
7099           switch (name[1])
7100           {
7101             case 'c':
7102               {                                   /* lc         */
7103                 return -KEY_lc;
7104               }
7105
7106             case 'e':
7107               {                                   /* le         */
7108                 return -KEY_le;
7109               }
7110
7111             case 't':
7112               {                                   /* lt         */
7113                 return -KEY_lt;
7114               }
7115
7116             default:
7117               goto unknown;
7118           }
7119
7120         case 'm':
7121           if (name[1] == 'y')
7122           {                                       /* my         */
7123             return KEY_my;
7124           }
7125
7126           goto unknown;
7127
7128         case 'n':
7129           switch (name[1])
7130           {
7131             case 'e':
7132               {                                   /* ne         */
7133                 return -KEY_ne;
7134               }
7135
7136             case 'o':
7137               {                                   /* no         */
7138                 return KEY_no;
7139               }
7140
7141             default:
7142               goto unknown;
7143           }
7144
7145         case 'o':
7146           if (name[1] == 'r')
7147           {                                       /* or         */
7148             return -KEY_or;
7149           }
7150
7151           goto unknown;
7152
7153         case 'q':
7154           switch (name[1])
7155           {
7156             case 'q':
7157               {                                   /* qq         */
7158                 return KEY_qq;
7159               }
7160
7161             case 'r':
7162               {                                   /* qr         */
7163                 return KEY_qr;
7164               }
7165
7166             case 'w':
7167               {                                   /* qw         */
7168                 return KEY_qw;
7169               }
7170
7171             case 'x':
7172               {                                   /* qx         */
7173                 return KEY_qx;
7174               }
7175
7176             default:
7177               goto unknown;
7178           }
7179
7180         case 't':
7181           if (name[1] == 'r')
7182           {                                       /* tr         */
7183             return KEY_tr;
7184           }
7185
7186           goto unknown;
7187
7188         case 'u':
7189           if (name[1] == 'c')
7190           {                                       /* uc         */
7191             return -KEY_uc;
7192           }
7193
7194           goto unknown;
7195
7196         default:
7197           goto unknown;
7198       }
7199
7200     case 3: /* 29 tokens of length 3 */
7201       switch (name[0])
7202       {
7203         case 'E':
7204           if (name[1] == 'N' &&
7205               name[2] == 'D')
7206           {                                       /* END        */
7207             return KEY_END;
7208           }
7209
7210           goto unknown;
7211
7212         case 'a':
7213           switch (name[1])
7214           {
7215             case 'b':
7216               if (name[2] == 's')
7217               {                                   /* abs        */
7218                 return -KEY_abs;
7219               }
7220
7221               goto unknown;
7222
7223             case 'n':
7224               if (name[2] == 'd')
7225               {                                   /* and        */
7226                 return -KEY_and;
7227               }
7228
7229               goto unknown;
7230
7231             default:
7232               goto unknown;
7233           }
7234
7235         case 'c':
7236           switch (name[1])
7237           {
7238             case 'h':
7239               if (name[2] == 'r')
7240               {                                   /* chr        */
7241                 return -KEY_chr;
7242               }
7243
7244               goto unknown;
7245
7246             case 'm':
7247               if (name[2] == 'p')
7248               {                                   /* cmp        */
7249                 return -KEY_cmp;
7250               }
7251
7252               goto unknown;
7253
7254             case 'o':
7255               if (name[2] == 's')
7256               {                                   /* cos        */
7257                 return -KEY_cos;
7258               }
7259
7260               goto unknown;
7261
7262             default:
7263               goto unknown;
7264           }
7265
7266         case 'd':
7267           if (name[1] == 'i' &&
7268               name[2] == 'e')
7269           {                                       /* die        */
7270             return -KEY_die;
7271           }
7272
7273           goto unknown;
7274
7275         case 'e':
7276           switch (name[1])
7277           {
7278             case 'o':
7279               if (name[2] == 'f')
7280               {                                   /* eof        */
7281                 return -KEY_eof;
7282               }
7283
7284               goto unknown;
7285
7286             case 'r':
7287               if (name[2] == 'r')
7288               {                                   /* err        */
7289                 return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0);
7290               }
7291
7292               goto unknown;
7293
7294             case 'x':
7295               if (name[2] == 'p')
7296               {                                   /* exp        */
7297                 return -KEY_exp;
7298               }
7299
7300               goto unknown;
7301
7302             default:
7303               goto unknown;
7304           }
7305
7306         case 'f':
7307           if (name[1] == 'o' &&
7308               name[2] == 'r')
7309           {                                       /* for        */
7310             return KEY_for;
7311           }
7312
7313           goto unknown;
7314
7315         case 'h':
7316           if (name[1] == 'e' &&
7317               name[2] == 'x')
7318           {                                       /* hex        */
7319             return -KEY_hex;
7320           }
7321
7322           goto unknown;
7323
7324         case 'i':
7325           if (name[1] == 'n' &&
7326               name[2] == 't')
7327           {                                       /* int        */
7328             return -KEY_int;
7329           }
7330
7331           goto unknown;
7332
7333         case 'l':
7334           if (name[1] == 'o' &&
7335               name[2] == 'g')
7336           {                                       /* log        */
7337             return -KEY_log;
7338           }
7339
7340           goto unknown;
7341
7342         case 'm':
7343           if (name[1] == 'a' &&
7344               name[2] == 'p')
7345           {                                       /* map        */
7346             return KEY_map;
7347           }
7348
7349           goto unknown;
7350
7351         case 'n':
7352           if (name[1] == 'o' &&
7353               name[2] == 't')
7354           {                                       /* not        */
7355             return -KEY_not;
7356           }
7357
7358           goto unknown;
7359
7360         case 'o':
7361           switch (name[1])
7362           {
7363             case 'c':
7364               if (name[2] == 't')
7365               {                                   /* oct        */
7366                 return -KEY_oct;
7367               }
7368
7369               goto unknown;
7370
7371             case 'r':
7372               if (name[2] == 'd')
7373               {                                   /* ord        */
7374                 return -KEY_ord;
7375               }
7376
7377               goto unknown;
7378
7379             case 'u':
7380               if (name[2] == 'r')
7381               {                                   /* our        */
7382                 return KEY_our;
7383               }
7384
7385               goto unknown;
7386
7387             default:
7388               goto unknown;
7389           }
7390
7391         case 'p':
7392           if (name[1] == 'o')
7393           {
7394             switch (name[2])
7395             {
7396               case 'p':
7397                 {                                 /* pop        */
7398                   return -KEY_pop;
7399                 }
7400
7401               case 's':
7402                 {                                 /* pos        */
7403                   return KEY_pos;
7404                 }
7405
7406               default:
7407                 goto unknown;
7408             }
7409           }
7410
7411           goto unknown;
7412
7413         case 'r':
7414           if (name[1] == 'e' &&
7415               name[2] == 'f')
7416           {                                       /* ref        */
7417             return -KEY_ref;
7418           }
7419
7420           goto unknown;
7421
7422         case 's':
7423           switch (name[1])
7424           {
7425             case 'a':
7426               if (name[2] == 'y')
7427               {                                   /* say        */
7428                 return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0);
7429               }
7430
7431               goto unknown;
7432
7433             case 'i':
7434               if (name[2] == 'n')
7435               {                                   /* sin        */
7436                 return -KEY_sin;
7437               }
7438
7439               goto unknown;
7440
7441             case 'u':
7442               if (name[2] == 'b')
7443               {                                   /* sub        */
7444                 return KEY_sub;
7445               }
7446
7447               goto unknown;
7448
7449             default:
7450               goto unknown;
7451           }
7452
7453         case 't':
7454           if (name[1] == 'i' &&
7455               name[2] == 'e')
7456           {                                       /* tie        */
7457             return KEY_tie;
7458           }
7459
7460           goto unknown;
7461
7462         case 'u':
7463           if (name[1] == 's' &&
7464               name[2] == 'e')
7465           {                                       /* use        */
7466             return KEY_use;
7467           }
7468
7469           goto unknown;
7470
7471         case 'v':
7472           if (name[1] == 'e' &&
7473               name[2] == 'c')
7474           {                                       /* vec        */
7475             return -KEY_vec;
7476           }
7477
7478           goto unknown;
7479
7480         case 'x':
7481           if (name[1] == 'o' &&
7482               name[2] == 'r')
7483           {                                       /* xor        */
7484             return -KEY_xor;
7485           }
7486
7487           goto unknown;
7488
7489         default:
7490           goto unknown;
7491       }
7492
7493     case 4: /* 41 tokens of length 4 */
7494       switch (name[0])
7495       {
7496         case 'C':
7497           if (name[1] == 'O' &&
7498               name[2] == 'R' &&
7499               name[3] == 'E')
7500           {                                       /* CORE       */
7501             return -KEY_CORE;
7502           }
7503
7504           goto unknown;
7505
7506         case 'I':
7507           if (name[1] == 'N' &&
7508               name[2] == 'I' &&
7509               name[3] == 'T')
7510           {                                       /* INIT       */
7511             return KEY_INIT;
7512           }
7513
7514           goto unknown;
7515
7516         case 'b':
7517           if (name[1] == 'i' &&
7518               name[2] == 'n' &&
7519               name[3] == 'd')
7520           {                                       /* bind       */
7521             return -KEY_bind;
7522           }
7523
7524           goto unknown;
7525
7526         case 'c':
7527           if (name[1] == 'h' &&
7528               name[2] == 'o' &&
7529               name[3] == 'p')
7530           {                                       /* chop       */
7531             return -KEY_chop;
7532           }
7533
7534           goto unknown;
7535
7536         case 'd':
7537           if (name[1] == 'u' &&
7538               name[2] == 'm' &&
7539               name[3] == 'p')
7540           {                                       /* dump       */
7541             return -KEY_dump;
7542           }
7543
7544           goto unknown;
7545
7546         case 'e':
7547           switch (name[1])
7548           {
7549             case 'a':
7550               if (name[2] == 'c' &&
7551                   name[3] == 'h')
7552               {                                   /* each       */
7553                 return -KEY_each;
7554               }
7555
7556               goto unknown;
7557
7558             case 'l':
7559               if (name[2] == 's' &&
7560                   name[3] == 'e')
7561               {                                   /* else       */
7562                 return KEY_else;
7563               }
7564
7565               goto unknown;
7566
7567             case 'v':
7568               if (name[2] == 'a' &&
7569                   name[3] == 'l')
7570               {                                   /* eval       */
7571                 return KEY_eval;
7572               }
7573
7574               goto unknown;
7575
7576             case 'x':
7577               switch (name[2])
7578               {
7579                 case 'e':
7580                   if (name[3] == 'c')
7581                   {                               /* exec       */
7582                     return -KEY_exec;
7583                   }
7584
7585                   goto unknown;
7586
7587                 case 'i':
7588                   if (name[3] == 't')
7589                   {                               /* exit       */
7590                     return -KEY_exit;
7591                   }
7592
7593                   goto unknown;
7594
7595                 default:
7596                   goto unknown;
7597               }
7598
7599             default:
7600               goto unknown;
7601           }
7602
7603         case 'f':
7604           if (name[1] == 'o' &&
7605               name[2] == 'r' &&
7606               name[3] == 'k')
7607           {                                       /* fork       */
7608             return -KEY_fork;
7609           }
7610
7611           goto unknown;
7612
7613         case 'g':
7614           switch (name[1])
7615           {
7616             case 'e':
7617               if (name[2] == 't' &&
7618                   name[3] == 'c')
7619               {                                   /* getc       */
7620                 return -KEY_getc;
7621               }
7622
7623               goto unknown;
7624
7625             case 'l':
7626               if (name[2] == 'o' &&
7627                   name[3] == 'b')
7628               {                                   /* glob       */
7629                 return KEY_glob;
7630               }
7631
7632               goto unknown;
7633
7634             case 'o':
7635               if (name[2] == 't' &&
7636                   name[3] == 'o')
7637               {                                   /* goto       */
7638                 return KEY_goto;
7639               }
7640
7641               goto unknown;
7642
7643             case 'r':
7644               if (name[2] == 'e' &&
7645                   name[3] == 'p')
7646               {                                   /* grep       */
7647                 return KEY_grep;
7648               }
7649
7650               goto unknown;
7651
7652             default:
7653               goto unknown;
7654           }
7655
7656         case 'j':
7657           if (name[1] == 'o' &&
7658               name[2] == 'i' &&
7659               name[3] == 'n')
7660           {                                       /* join       */
7661             return -KEY_join;
7662           }
7663
7664           goto unknown;
7665
7666         case 'k':
7667           switch (name[1])
7668           {
7669             case 'e':
7670               if (name[2] == 'y' &&
7671                   name[3] == 's')
7672               {                                   /* keys       */
7673                 return -KEY_keys;
7674               }
7675
7676               goto unknown;
7677
7678             case 'i':
7679               if (name[2] == 'l' &&
7680                   name[3] == 'l')
7681               {                                   /* kill       */
7682                 return -KEY_kill;
7683               }
7684
7685               goto unknown;
7686
7687             default:
7688               goto unknown;
7689           }
7690
7691         case 'l':
7692           switch (name[1])
7693           {
7694             case 'a':
7695               if (name[2] == 's' &&
7696                   name[3] == 't')
7697               {                                   /* last       */
7698                 return KEY_last;
7699               }
7700
7701               goto unknown;
7702
7703             case 'i':
7704               if (name[2] == 'n' &&
7705                   name[3] == 'k')
7706               {                                   /* link       */
7707                 return -KEY_link;
7708               }
7709
7710               goto unknown;
7711
7712             case 'o':
7713               if (name[2] == 'c' &&
7714                   name[3] == 'k')
7715               {                                   /* lock       */
7716                 return -KEY_lock;
7717               }
7718
7719               goto unknown;
7720
7721             default:
7722               goto unknown;
7723           }
7724
7725         case 'n':
7726           if (name[1] == 'e' &&
7727               name[2] == 'x' &&
7728               name[3] == 't')
7729           {                                       /* next       */
7730             return KEY_next;
7731           }
7732
7733           goto unknown;
7734
7735         case 'o':
7736           if (name[1] == 'p' &&
7737               name[2] == 'e' &&
7738               name[3] == 'n')
7739           {                                       /* open       */
7740             return -KEY_open;
7741           }
7742
7743           goto unknown;
7744
7745         case 'p':
7746           switch (name[1])
7747           {
7748             case 'a':
7749               if (name[2] == 'c' &&
7750                   name[3] == 'k')
7751               {                                   /* pack       */
7752                 return -KEY_pack;
7753               }
7754
7755               goto unknown;
7756
7757             case 'i':
7758               if (name[2] == 'p' &&
7759                   name[3] == 'e')
7760               {                                   /* pipe       */
7761                 return -KEY_pipe;
7762               }
7763
7764               goto unknown;
7765
7766             case 'u':
7767               if (name[2] == 's' &&
7768                   name[3] == 'h')
7769               {                                   /* push       */
7770                 return -KEY_push;
7771               }
7772
7773               goto unknown;
7774
7775             default:
7776               goto unknown;
7777           }
7778
7779         case 'r':
7780           switch (name[1])
7781           {
7782             case 'a':
7783               if (name[2] == 'n' &&
7784                   name[3] == 'd')
7785               {                                   /* rand       */
7786                 return -KEY_rand;
7787               }
7788
7789               goto unknown;
7790
7791             case 'e':
7792               switch (name[2])
7793               {
7794                 case 'a':
7795                   if (name[3] == 'd')
7796                   {                               /* read       */
7797                     return -KEY_read;
7798                   }
7799
7800                   goto unknown;
7801
7802                 case 'c':
7803                   if (name[3] == 'v')
7804                   {                               /* recv       */
7805                     return -KEY_recv;
7806                   }
7807
7808                   goto unknown;
7809
7810                 case 'd':
7811                   if (name[3] == 'o')
7812                   {                               /* redo       */
7813                     return KEY_redo;
7814                   }
7815
7816                   goto unknown;
7817
7818                 default:
7819                   goto unknown;
7820               }
7821
7822             default:
7823               goto unknown;
7824           }
7825
7826         case 's':
7827           switch (name[1])
7828           {
7829             case 'e':
7830               switch (name[2])
7831               {
7832                 case 'e':
7833                   if (name[3] == 'k')
7834                   {                               /* seek       */
7835                     return -KEY_seek;
7836                   }
7837
7838                   goto unknown;
7839
7840                 case 'n':
7841                   if (name[3] == 'd')
7842                   {                               /* send       */
7843                     return -KEY_send;
7844                   }
7845
7846                   goto unknown;
7847
7848                 default:
7849                   goto unknown;
7850               }
7851
7852             case 'o':
7853               if (name[2] == 'r' &&
7854                   name[3] == 't')
7855               {                                   /* sort       */
7856                 return KEY_sort;
7857               }
7858
7859               goto unknown;
7860
7861             case 'q':
7862               if (name[2] == 'r' &&
7863                   name[3] == 't')
7864               {                                   /* sqrt       */
7865                 return -KEY_sqrt;
7866               }
7867
7868               goto unknown;
7869
7870             case 't':
7871               if (name[2] == 'a' &&
7872                   name[3] == 't')
7873               {                                   /* stat       */
7874                 return -KEY_stat;
7875               }
7876
7877               goto unknown;
7878
7879             default:
7880               goto unknown;
7881           }
7882
7883         case 't':
7884           switch (name[1])
7885           {
7886             case 'e':
7887               if (name[2] == 'l' &&
7888                   name[3] == 'l')
7889               {                                   /* tell       */
7890                 return -KEY_tell;
7891               }
7892
7893               goto unknown;
7894
7895             case 'i':
7896               switch (name[2])
7897               {
7898                 case 'e':
7899                   if (name[3] == 'd')
7900                   {                               /* tied       */
7901                     return KEY_tied;
7902                   }
7903
7904                   goto unknown;
7905
7906                 case 'm':
7907                   if (name[3] == 'e')
7908                   {                               /* time       */
7909                     return -KEY_time;
7910                   }
7911
7912                   goto unknown;
7913
7914                 default:
7915                   goto unknown;
7916               }
7917
7918             default:
7919               goto unknown;
7920           }
7921
7922         case 'w':
7923           switch (name[1])
7924           {
7925             case 'a':
7926               switch (name[2])
7927               {
7928                 case 'i':
7929                   if (name[3] == 't')
7930                   {                               /* wait       */
7931                     return -KEY_wait;
7932                   }
7933
7934                   goto unknown;
7935
7936                 case 'r':
7937                   if (name[3] == 'n')
7938                   {                               /* warn       */
7939                     return -KEY_warn;
7940                   }
7941
7942                   goto unknown;
7943
7944                 default:
7945                   goto unknown;
7946               }
7947
7948             case 'h':
7949               if (name[2] == 'e' &&
7950                   name[3] == 'n')
7951               {                                   /* when       */
7952                 return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0);
7953               }
7954
7955               goto unknown;
7956
7957             default:
7958               goto unknown;
7959           }
7960
7961         default:
7962           goto unknown;
7963       }
7964
7965     case 5: /* 39 tokens of length 5 */
7966       switch (name[0])
7967       {
7968         case 'B':
7969           if (name[1] == 'E' &&
7970               name[2] == 'G' &&
7971               name[3] == 'I' &&
7972               name[4] == 'N')
7973           {                                       /* BEGIN      */
7974             return KEY_BEGIN;
7975           }
7976
7977           goto unknown;
7978
7979         case 'C':
7980           if (name[1] == 'H' &&
7981               name[2] == 'E' &&
7982               name[3] == 'C' &&
7983               name[4] == 'K')
7984           {                                       /* CHECK      */
7985             return KEY_CHECK;
7986           }
7987
7988           goto unknown;
7989
7990         case 'a':
7991           switch (name[1])
7992           {
7993             case 'l':
7994               if (name[2] == 'a' &&
7995                   name[3] == 'r' &&
7996                   name[4] == 'm')
7997               {                                   /* alarm      */
7998                 return -KEY_alarm;
7999               }
8000
8001               goto unknown;
8002
8003             case 't':
8004               if (name[2] == 'a' &&
8005                   name[3] == 'n' &&
8006                   name[4] == '2')
8007               {                                   /* atan2      */
8008                 return -KEY_atan2;
8009               }
8010
8011               goto unknown;
8012
8013             default:
8014               goto unknown;
8015           }
8016
8017         case 'b':
8018           switch (name[1])
8019           {
8020             case 'l':
8021               if (name[2] == 'e' &&
8022                   name[3] == 's' &&
8023                   name[4] == 's')
8024               {                                   /* bless      */
8025                 return -KEY_bless;
8026               }
8027
8028               goto unknown;
8029
8030             case 'r':
8031               if (name[2] == 'e' &&
8032                   name[3] == 'a' &&
8033                   name[4] == 'k')
8034               {                                   /* break      */
8035                 return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0);
8036               }
8037
8038               goto unknown;
8039
8040             default:
8041               goto unknown;
8042           }
8043
8044         case 'c':
8045           switch (name[1])
8046           {
8047             case 'h':
8048               switch (name[2])
8049               {
8050                 case 'd':
8051                   if (name[3] == 'i' &&
8052                       name[4] == 'r')
8053                   {                               /* chdir      */
8054                     return -KEY_chdir;
8055                   }
8056
8057                   goto unknown;
8058
8059                 case 'm':
8060                   if (name[3] == 'o' &&
8061                       name[4] == 'd')
8062                   {                               /* chmod      */
8063                     return -KEY_chmod;
8064                   }
8065
8066                   goto unknown;
8067
8068                 case 'o':
8069                   switch (name[3])
8070                   {
8071                     case 'm':
8072                       if (name[4] == 'p')
8073                       {                           /* chomp      */
8074                         return -KEY_chomp;
8075                       }
8076
8077                       goto unknown;
8078
8079                     case 'w':
8080                       if (name[4] == 'n')
8081                       {                           /* chown      */
8082                         return -KEY_chown;
8083                       }
8084
8085                       goto unknown;
8086
8087                     default:
8088                       goto unknown;
8089                   }
8090
8091                 default:
8092                   goto unknown;
8093               }
8094
8095             case 'l':
8096               if (name[2] == 'o' &&
8097                   name[3] == 's' &&
8098                   name[4] == 'e')
8099               {                                   /* close      */
8100                 return -KEY_close;
8101               }
8102
8103               goto unknown;
8104
8105             case 'r':
8106               if (name[2] == 'y' &&
8107                   name[3] == 'p' &&
8108                   name[4] == 't')
8109               {                                   /* crypt      */
8110                 return -KEY_crypt;
8111               }
8112
8113               goto unknown;
8114
8115             default:
8116               goto unknown;
8117           }
8118
8119         case 'e':
8120           if (name[1] == 'l' &&
8121               name[2] == 's' &&
8122               name[3] == 'i' &&
8123               name[4] == 'f')
8124           {                                       /* elsif      */
8125             return KEY_elsif;
8126           }
8127
8128           goto unknown;
8129
8130         case 'f':
8131           switch (name[1])
8132           {
8133             case 'c':
8134               if (name[2] == 'n' &&
8135                   name[3] == 't' &&
8136                   name[4] == 'l')
8137               {                                   /* fcntl      */
8138                 return -KEY_fcntl;
8139               }
8140
8141               goto unknown;
8142
8143             case 'l':
8144               if (name[2] == 'o' &&
8145                   name[3] == 'c' &&
8146                   name[4] == 'k')
8147               {                                   /* flock      */
8148                 return -KEY_flock;
8149               }
8150
8151               goto unknown;
8152
8153             default:
8154               goto unknown;
8155           }
8156
8157         case 'g':
8158           if (name[1] == 'i' &&
8159               name[2] == 'v' &&
8160               name[3] == 'e' &&
8161               name[4] == 'n')
8162           {                                       /* given      */
8163             return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0);
8164           }
8165
8166           goto unknown;
8167
8168         case 'i':
8169           switch (name[1])
8170           {
8171             case 'n':
8172               if (name[2] == 'd' &&
8173                   name[3] == 'e' &&
8174                   name[4] == 'x')
8175               {                                   /* index      */
8176                 return -KEY_index;
8177               }
8178
8179               goto unknown;
8180
8181             case 'o':
8182               if (name[2] == 'c' &&
8183                   name[3] == 't' &&
8184                   name[4] == 'l')
8185               {                                   /* ioctl      */
8186                 return -KEY_ioctl;
8187               }
8188
8189               goto unknown;
8190
8191             default:
8192               goto unknown;
8193           }
8194
8195         case 'l':
8196           switch (name[1])
8197           {
8198             case 'o':
8199               if (name[2] == 'c' &&
8200                   name[3] == 'a' &&
8201                   name[4] == 'l')
8202               {                                   /* local      */
8203                 return KEY_local;
8204               }
8205
8206               goto unknown;
8207
8208             case 's':
8209               if (name[2] == 't' &&
8210                   name[3] == 'a' &&
8211                   name[4] == 't')
8212               {                                   /* lstat      */
8213                 return -KEY_lstat;
8214               }
8215
8216               goto unknown;
8217
8218             default:
8219               goto unknown;
8220           }
8221
8222         case 'm':
8223           if (name[1] == 'k' &&
8224               name[2] == 'd' &&
8225               name[3] == 'i' &&
8226               name[4] == 'r')
8227           {                                       /* mkdir      */
8228             return -KEY_mkdir;
8229           }
8230
8231           goto unknown;
8232
8233         case 'p':
8234           if (name[1] == 'r' &&
8235               name[2] == 'i' &&
8236               name[3] == 'n' &&
8237               name[4] == 't')
8238           {                                       /* print      */
8239             return KEY_print;
8240           }
8241
8242           goto unknown;
8243
8244         case 'r':
8245           switch (name[1])
8246           {
8247             case 'e':
8248               if (name[2] == 's' &&
8249                   name[3] == 'e' &&
8250                   name[4] == 't')
8251               {                                   /* reset      */
8252                 return -KEY_reset;
8253               }
8254
8255               goto unknown;
8256
8257             case 'm':
8258               if (name[2] == 'd' &&
8259                   name[3] == 'i' &&
8260                   name[4] == 'r')
8261               {                                   /* rmdir      */
8262                 return -KEY_rmdir;
8263               }
8264
8265               goto unknown;
8266
8267             default:
8268               goto unknown;
8269           }
8270
8271         case 's':
8272           switch (name[1])
8273           {
8274             case 'e':
8275               if (name[2] == 'm' &&
8276                   name[3] == 'o' &&
8277                   name[4] == 'p')
8278               {                                   /* semop      */
8279                 return -KEY_semop;
8280               }
8281
8282               goto unknown;
8283
8284             case 'h':
8285               if (name[2] == 'i' &&
8286                   name[3] == 'f' &&
8287                   name[4] == 't')
8288               {                                   /* shift      */
8289                 return -KEY_shift;
8290               }
8291
8292               goto unknown;
8293
8294             case 'l':
8295               if (name[2] == 'e' &&
8296                   name[3] == 'e' &&
8297                   name[4] == 'p')
8298               {                                   /* sleep      */
8299                 return -KEY_sleep;
8300               }
8301
8302               goto unknown;
8303
8304             case 'p':
8305               if (name[2] == 'l' &&
8306                   name[3] == 'i' &&
8307                   name[4] == 't')
8308               {                                   /* split      */
8309                 return KEY_split;
8310               }
8311
8312               goto unknown;
8313
8314             case 'r':
8315               if (name[2] == 'a' &&
8316                   name[3] == 'n' &&
8317                   name[4] == 'd')
8318               {                                   /* srand      */
8319                 return -KEY_srand;
8320               }
8321
8322               goto unknown;
8323
8324             case 't':
8325               switch (name[2])
8326               {
8327                 case 'a':
8328                   if (name[3] == 't' &&
8329                       name[4] == 'e')
8330                   {                               /* state      */
8331                     return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0);
8332                   }
8333
8334                   goto unknown;
8335
8336                 case 'u':
8337                   if (name[3] == 'd' &&
8338                       name[4] == 'y')
8339                   {                               /* study      */
8340                     return KEY_study;
8341                   }
8342
8343                   goto unknown;
8344
8345                 default:
8346                   goto unknown;
8347               }
8348
8349             default:
8350               goto unknown;
8351           }
8352
8353         case 't':
8354           if (name[1] == 'i' &&
8355               name[2] == 'm' &&
8356               name[3] == 'e' &&
8357               name[4] == 's')
8358           {                                       /* times      */
8359             return -KEY_times;
8360           }
8361
8362           goto unknown;
8363
8364         case 'u':
8365           switch (name[1])
8366           {
8367             case 'm':
8368               if (name[2] == 'a' &&
8369                   name[3] == 's' &&
8370                   name[4] == 'k')
8371               {                                   /* umask      */
8372                 return -KEY_umask;
8373               }
8374
8375               goto unknown;
8376
8377             case 'n':
8378               switch (name[2])
8379               {
8380                 case 'd':
8381                   if (name[3] == 'e' &&
8382                       name[4] == 'f')
8383                   {                               /* undef      */
8384                     return KEY_undef;
8385                   }
8386
8387                   goto unknown;
8388
8389                 case 't':
8390                   if (name[3] == 'i')
8391                   {
8392                     switch (name[4])
8393                     {
8394                       case 'e':
8395                         {                         /* untie      */
8396                           return KEY_untie;
8397                         }
8398
8399                       case 'l':
8400                         {                         /* until      */
8401                           return KEY_until;
8402                         }
8403
8404                       default:
8405                         goto unknown;
8406                     }
8407                   }
8408
8409                   goto unknown;
8410
8411                 default:
8412                   goto unknown;
8413               }
8414
8415             case 't':
8416               if (name[2] == 'i' &&
8417                   name[3] == 'm' &&
8418                   name[4] == 'e')
8419               {                                   /* utime      */
8420                 return -KEY_utime;
8421               }
8422
8423               goto unknown;
8424
8425             default:
8426               goto unknown;
8427           }
8428
8429         case 'w':
8430           switch (name[1])
8431           {
8432             case 'h':
8433               if (name[2] == 'i' &&
8434                   name[3] == 'l' &&
8435                   name[4] == 'e')
8436               {                                   /* while      */
8437                 return KEY_while;
8438               }
8439
8440               goto unknown;
8441
8442             case 'r':
8443               if (name[2] == 'i' &&
8444                   name[3] == 't' &&
8445                   name[4] == 'e')
8446               {                                   /* write      */
8447                 return -KEY_write;
8448               }
8449
8450               goto unknown;
8451
8452             default:
8453               goto unknown;
8454           }
8455
8456         default:
8457           goto unknown;
8458       }
8459
8460     case 6: /* 33 tokens of length 6 */
8461       switch (name[0])
8462       {
8463         case 'a':
8464           if (name[1] == 'c' &&
8465               name[2] == 'c' &&
8466               name[3] == 'e' &&
8467               name[4] == 'p' &&
8468               name[5] == 't')
8469           {                                       /* accept     */
8470             return -KEY_accept;
8471           }
8472
8473           goto unknown;
8474
8475         case 'c':
8476           switch (name[1])
8477           {
8478             case 'a':
8479               if (name[2] == 'l' &&
8480                   name[3] == 'l' &&
8481                   name[4] == 'e' &&
8482                   name[5] == 'r')
8483               {                                   /* caller     */
8484                 return -KEY_caller;
8485               }
8486
8487               goto unknown;
8488
8489             case 'h':
8490               if (name[2] == 'r' &&
8491                   name[3] == 'o' &&
8492                   name[4] == 'o' &&
8493                   name[5] == 't')
8494               {                                   /* chroot     */
8495                 return -KEY_chroot;
8496               }
8497
8498               goto unknown;
8499
8500             default:
8501               goto unknown;
8502           }
8503
8504         case 'd':
8505           if (name[1] == 'e' &&
8506               name[2] == 'l' &&
8507               name[3] == 'e' &&
8508               name[4] == 't' &&
8509               name[5] == 'e')
8510           {                                       /* delete     */
8511             return KEY_delete;
8512           }
8513
8514           goto unknown;
8515
8516         case 'e':
8517           switch (name[1])
8518           {
8519             case 'l':
8520               if (name[2] == 's' &&
8521                   name[3] == 'e' &&
8522                   name[4] == 'i' &&
8523                   name[5] == 'f')
8524               {                                   /* elseif     */
8525                 if(ckWARN_d(WARN_SYNTAX))
8526                   Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "elseif should be elsif");
8527               }
8528
8529               goto unknown;
8530
8531             case 'x':
8532               if (name[2] == 'i' &&
8533                   name[3] == 's' &&
8534                   name[4] == 't' &&
8535                   name[5] == 's')
8536               {                                   /* exists     */
8537                 return KEY_exists;
8538               }
8539
8540               goto unknown;
8541
8542             default:
8543               goto unknown;
8544           }
8545
8546         case 'f':
8547           switch (name[1])
8548           {
8549             case 'i':
8550               if (name[2] == 'l' &&
8551                   name[3] == 'e' &&
8552                   name[4] == 'n' &&
8553                   name[5] == 'o')
8554               {                                   /* fileno     */
8555                 return -KEY_fileno;
8556               }
8557
8558               goto unknown;
8559
8560             case 'o':
8561               if (name[2] == 'r' &&
8562                   name[3] == 'm' &&
8563                   name[4] == 'a' &&
8564                   name[5] == 't')
8565               {                                   /* format     */
8566                 return KEY_format;
8567               }
8568
8569               goto unknown;
8570
8571             default:
8572               goto unknown;
8573           }
8574
8575         case 'g':
8576           if (name[1] == 'm' &&
8577               name[2] == 't' &&
8578               name[3] == 'i' &&
8579               name[4] == 'm' &&
8580               name[5] == 'e')
8581           {                                       /* gmtime     */
8582             return -KEY_gmtime;
8583           }
8584
8585           goto unknown;
8586
8587         case 'l':
8588           switch (name[1])
8589           {
8590             case 'e':
8591               if (name[2] == 'n' &&
8592                   name[3] == 'g' &&
8593                   name[4] == 't' &&
8594                   name[5] == 'h')
8595               {                                   /* length     */
8596                 return -KEY_length;
8597               }
8598
8599               goto unknown;
8600
8601             case 'i':
8602               if (name[2] == 's' &&
8603                   name[3] == 't' &&
8604                   name[4] == 'e' &&
8605                   name[5] == 'n')
8606               {                                   /* listen     */
8607                 return -KEY_listen;
8608               }
8609
8610               goto unknown;
8611
8612             default:
8613               goto unknown;
8614           }
8615
8616         case 'm':
8617           if (name[1] == 's' &&
8618               name[2] == 'g')
8619           {
8620             switch (name[3])
8621             {
8622               case 'c':
8623                 if (name[4] == 't' &&
8624                     name[5] == 'l')
8625                 {                                 /* msgctl     */
8626                   return -KEY_msgctl;
8627                 }
8628
8629                 goto unknown;
8630
8631               case 'g':
8632                 if (name[4] == 'e' &&
8633                     name[5] == 't')
8634                 {                                 /* msgget     */
8635                   return -KEY_msgget;
8636                 }
8637
8638                 goto unknown;
8639
8640               case 'r':
8641                 if (name[4] == 'c' &&
8642                     name[5] == 'v')
8643                 {                                 /* msgrcv     */
8644                   return -KEY_msgrcv;
8645                 }
8646
8647                 goto unknown;
8648
8649               case 's':
8650                 if (name[4] == 'n' &&
8651                     name[5] == 'd')
8652                 {                                 /* msgsnd     */
8653                   return -KEY_msgsnd;
8654                 }
8655
8656                 goto unknown;
8657
8658               default:
8659                 goto unknown;
8660             }
8661           }
8662
8663           goto unknown;
8664
8665         case 'p':
8666           if (name[1] == 'r' &&
8667               name[2] == 'i' &&
8668               name[3] == 'n' &&
8669               name[4] == 't' &&
8670               name[5] == 'f')
8671           {                                       /* printf     */
8672             return KEY_printf;
8673           }
8674
8675           goto unknown;
8676
8677         case 'r':
8678           switch (name[1])
8679           {
8680             case 'e':
8681               switch (name[2])
8682               {
8683                 case 'n':
8684                   if (name[3] == 'a' &&
8685                       name[4] == 'm' &&
8686                       name[5] == 'e')
8687                   {                               /* rename     */
8688                     return -KEY_rename;
8689                   }
8690
8691                   goto unknown;
8692
8693                 case 't':
8694                   if (name[3] == 'u' &&
8695                       name[4] == 'r' &&
8696                       name[5] == 'n')
8697                   {                               /* return     */
8698                     return KEY_return;
8699                   }
8700
8701                   goto unknown;
8702
8703                 default:
8704                   goto unknown;
8705               }
8706
8707             case 'i':
8708               if (name[2] == 'n' &&
8709                   name[3] == 'd' &&
8710                   name[4] == 'e' &&
8711                   name[5] == 'x')
8712               {                                   /* rindex     */
8713                 return -KEY_rindex;
8714               }
8715
8716               goto unknown;
8717
8718             default:
8719               goto unknown;
8720           }
8721
8722         case 's':
8723           switch (name[1])
8724           {
8725             case 'c':
8726               if (name[2] == 'a' &&
8727                   name[3] == 'l' &&
8728                   name[4] == 'a' &&
8729                   name[5] == 'r')
8730               {                                   /* scalar     */
8731                 return KEY_scalar;
8732               }
8733
8734               goto unknown;
8735
8736             case 'e':
8737               switch (name[2])
8738               {
8739                 case 'l':
8740                   if (name[3] == 'e' &&
8741                       name[4] == 'c' &&
8742                       name[5] == 't')
8743                   {                               /* select     */
8744                     return -KEY_select;
8745                   }
8746
8747                   goto unknown;
8748
8749                 case 'm':
8750                   switch (name[3])
8751                   {
8752                     case 'c':
8753                       if (name[4] == 't' &&
8754                           name[5] == 'l')
8755                       {                           /* semctl     */
8756                         return -KEY_semctl;
8757                       }
8758
8759                       goto unknown;
8760
8761                     case 'g':
8762                       if (name[4] == 'e' &&
8763                           name[5] == 't')
8764                       {                           /* semget     */
8765                         return -KEY_semget;
8766                       }
8767
8768                       goto unknown;
8769
8770                     default:
8771                       goto unknown;
8772                   }
8773
8774                 default:
8775                   goto unknown;
8776               }
8777
8778             case 'h':
8779               if (name[2] == 'm')
8780               {
8781                 switch (name[3])
8782                 {
8783                   case 'c':
8784                     if (name[4] == 't' &&
8785                         name[5] == 'l')
8786                     {                             /* shmctl     */
8787                       return -KEY_shmctl;
8788                     }
8789
8790                     goto unknown;
8791
8792                   case 'g':
8793                     if (name[4] == 'e' &&
8794                         name[5] == 't')
8795                     {                             /* shmget     */
8796                       return -KEY_shmget;
8797                     }
8798
8799                     goto unknown;
8800
8801                   default:
8802                     goto unknown;
8803                 }
8804               }
8805
8806               goto unknown;
8807
8808             case 'o':
8809               if (name[2] == 'c' &&
8810                   name[3] == 'k' &&
8811                   name[4] == 'e' &&
8812                   name[5] == 't')
8813               {                                   /* socket     */
8814                 return -KEY_socket;
8815               }
8816
8817               goto unknown;
8818
8819             case 'p':
8820               if (name[2] == 'l' &&
8821                   name[3] == 'i' &&
8822                   name[4] == 'c' &&
8823                   name[5] == 'e')
8824               {                                   /* splice     */
8825                 return -KEY_splice;
8826               }
8827
8828               goto unknown;
8829
8830             case 'u':
8831               if (name[2] == 'b' &&
8832                   name[3] == 's' &&
8833                   name[4] == 't' &&
8834                   name[5] == 'r')
8835               {                                   /* substr     */
8836                 return -KEY_substr;
8837               }
8838
8839               goto unknown;
8840
8841             case 'y':
8842               if (name[2] == 's' &&
8843                   name[3] == 't' &&
8844                   name[4] == 'e' &&
8845                   name[5] == 'm')
8846               {                                   /* system     */
8847                 return -KEY_system;
8848               }
8849
8850               goto unknown;
8851
8852             default:
8853               goto unknown;
8854           }
8855
8856         case 'u':
8857           if (name[1] == 'n')
8858           {
8859             switch (name[2])
8860             {
8861               case 'l':
8862                 switch (name[3])
8863                 {
8864                   case 'e':
8865                     if (name[4] == 's' &&
8866                         name[5] == 's')
8867                     {                             /* unless     */
8868                       return KEY_unless;
8869                     }
8870
8871                     goto unknown;
8872
8873                   case 'i':
8874                     if (name[4] == 'n' &&
8875                         name[5] == 'k')
8876                     {                             /* unlink     */
8877                       return -KEY_unlink;
8878                     }
8879
8880                     goto unknown;
8881
8882                   default:
8883                     goto unknown;
8884                 }
8885
8886               case 'p':
8887                 if (name[3] == 'a' &&
8888                     name[4] == 'c' &&
8889                     name[5] == 'k')
8890                 {                                 /* unpack     */
8891                   return -KEY_unpack;
8892                 }
8893
8894                 goto unknown;
8895
8896               default:
8897                 goto unknown;
8898             }
8899           }
8900
8901           goto unknown;
8902
8903         case 'v':
8904           if (name[1] == 'a' &&
8905               name[2] == 'l' &&
8906               name[3] == 'u' &&
8907               name[4] == 'e' &&
8908               name[5] == 's')
8909           {                                       /* values     */
8910             return -KEY_values;
8911           }
8912
8913           goto unknown;
8914
8915         default:
8916           goto unknown;
8917       }
8918
8919     case 7: /* 29 tokens of length 7 */
8920       switch (name[0])
8921       {
8922         case 'D':
8923           if (name[1] == 'E' &&
8924               name[2] == 'S' &&
8925               name[3] == 'T' &&
8926               name[4] == 'R' &&
8927               name[5] == 'O' &&
8928               name[6] == 'Y')
8929           {                                       /* DESTROY    */
8930             return KEY_DESTROY;
8931           }
8932
8933           goto unknown;
8934
8935         case '_':
8936           if (name[1] == '_' &&
8937               name[2] == 'E' &&
8938               name[3] == 'N' &&
8939               name[4] == 'D' &&
8940               name[5] == '_' &&
8941               name[6] == '_')
8942           {                                       /* __END__    */
8943             return KEY___END__;
8944           }
8945
8946           goto unknown;
8947
8948         case 'b':
8949           if (name[1] == 'i' &&
8950               name[2] == 'n' &&
8951               name[3] == 'm' &&
8952               name[4] == 'o' &&
8953               name[5] == 'd' &&
8954               name[6] == 'e')
8955           {                                       /* binmode    */
8956             return -KEY_binmode;
8957           }
8958
8959           goto unknown;
8960
8961         case 'c':
8962           if (name[1] == 'o' &&
8963               name[2] == 'n' &&
8964               name[3] == 'n' &&
8965               name[4] == 'e' &&
8966               name[5] == 'c' &&
8967               name[6] == 't')
8968           {                                       /* connect    */
8969             return -KEY_connect;
8970           }
8971
8972           goto unknown;
8973
8974         case 'd':
8975           switch (name[1])
8976           {
8977             case 'b':
8978               if (name[2] == 'm' &&
8979                   name[3] == 'o' &&
8980                   name[4] == 'p' &&
8981                   name[5] == 'e' &&
8982                   name[6] == 'n')
8983               {                                   /* dbmopen    */
8984                 return -KEY_dbmopen;
8985               }
8986
8987               goto unknown;
8988
8989             case 'e':
8990               if (name[2] == 'f')
8991               {
8992                 switch (name[3])
8993                 {
8994                   case 'a':
8995                     if (name[4] == 'u' &&
8996                         name[5] == 'l' &&
8997                         name[6] == 't')
8998                     {                             /* default    */
8999                       return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0);
9000                     }
9001
9002                     goto unknown;
9003
9004                   case 'i':
9005                     if (name[4] == 'n' &&
9006                         name[5] == 'e' &&
9007                         name[6] == 'd')
9008                     {                             /* defined    */
9009                       return KEY_defined;
9010                     }
9011
9012                     goto unknown;
9013
9014                   default:
9015                     goto unknown;
9016                 }
9017               }
9018
9019               goto unknown;
9020
9021             default:
9022               goto unknown;
9023           }
9024
9025         case 'f':
9026           if (name[1] == 'o' &&
9027               name[2] == 'r' &&
9028               name[3] == 'e' &&
9029               name[4] == 'a' &&
9030               name[5] == 'c' &&
9031               name[6] == 'h')
9032           {                                       /* foreach    */
9033             return KEY_foreach;
9034           }
9035
9036           goto unknown;
9037
9038         case 'g':
9039           if (name[1] == 'e' &&
9040               name[2] == 't' &&
9041               name[3] == 'p')
9042           {
9043             switch (name[4])
9044             {
9045               case 'g':
9046                 if (name[5] == 'r' &&
9047                     name[6] == 'p')
9048                 {                                 /* getpgrp    */
9049                   return -KEY_getpgrp;
9050                 }
9051
9052                 goto unknown;
9053
9054               case 'p':
9055                 if (name[5] == 'i' &&
9056                     name[6] == 'd')
9057                 {                                 /* getppid    */
9058                   return -KEY_getppid;
9059                 }
9060
9061                 goto unknown;
9062
9063               default:
9064                 goto unknown;
9065             }
9066           }
9067
9068           goto unknown;
9069
9070         case 'l':
9071           if (name[1] == 'c' &&
9072               name[2] == 'f' &&
9073               name[3] == 'i' &&
9074               name[4] == 'r' &&
9075               name[5] == 's' &&
9076               name[6] == 't')
9077           {                                       /* lcfirst    */
9078             return -KEY_lcfirst;
9079           }
9080
9081           goto unknown;
9082
9083         case 'o':
9084           if (name[1] == 'p' &&
9085               name[2] == 'e' &&
9086               name[3] == 'n' &&
9087               name[4] == 'd' &&
9088               name[5] == 'i' &&
9089               name[6] == 'r')
9090           {                                       /* opendir    */
9091             return -KEY_opendir;
9092           }
9093
9094           goto unknown;
9095
9096         case 'p':
9097           if (name[1] == 'a' &&
9098               name[2] == 'c' &&
9099               name[3] == 'k' &&
9100               name[4] == 'a' &&
9101               name[5] == 'g' &&
9102               name[6] == 'e')
9103           {                                       /* package    */
9104             return KEY_package;
9105           }
9106
9107           goto unknown;
9108
9109         case 'r':
9110           if (name[1] == 'e')
9111           {
9112             switch (name[2])
9113             {
9114               case 'a':
9115                 if (name[3] == 'd' &&
9116                     name[4] == 'd' &&
9117                     name[5] == 'i' &&
9118                     name[6] == 'r')
9119                 {                                 /* readdir    */
9120                   return -KEY_readdir;
9121                 }
9122
9123                 goto unknown;
9124
9125               case 'q':
9126                 if (name[3] == 'u' &&
9127                     name[4] == 'i' &&
9128                     name[5] == 'r' &&
9129                     name[6] == 'e')
9130                 {                                 /* require    */
9131                   return KEY_require;
9132                 }
9133
9134                 goto unknown;
9135
9136               case 'v':
9137                 if (name[3] == 'e' &&
9138                     name[4] == 'r' &&
9139                     name[5] == 's' &&
9140                     name[6] == 'e')
9141                 {                                 /* reverse    */
9142                   return -KEY_reverse;
9143                 }
9144
9145                 goto unknown;
9146
9147               default:
9148                 goto unknown;
9149             }
9150           }
9151
9152           goto unknown;
9153
9154         case 's':
9155           switch (name[1])
9156           {
9157             case 'e':
9158               switch (name[2])
9159               {
9160                 case 'e':
9161                   if (name[3] == 'k' &&
9162                       name[4] == 'd' &&
9163                       name[5] == 'i' &&
9164                       name[6] == 'r')
9165                   {                               /* seekdir    */
9166                     return -KEY_seekdir;
9167                   }
9168
9169                   goto unknown;
9170
9171                 case 't':
9172                   if (name[3] == 'p' &&
9173                       name[4] == 'g' &&
9174                       name[5] == 'r' &&
9175                       name[6] == 'p')
9176                   {                               /* setpgrp    */
9177                     return -KEY_setpgrp;
9178                   }
9179
9180                   goto unknown;
9181
9182                 default:
9183                   goto unknown;
9184               }
9185
9186             case 'h':
9187               if (name[2] == 'm' &&
9188                   name[3] == 'r' &&
9189                   name[4] == 'e' &&
9190                   name[5] == 'a' &&
9191                   name[6] == 'd')
9192               {                                   /* shmread    */
9193                 return -KEY_shmread;
9194               }
9195
9196               goto unknown;
9197
9198             case 'p':
9199               if (name[2] == 'r' &&
9200                   name[3] == 'i' &&
9201                   name[4] == 'n' &&
9202                   name[5] == 't' &&
9203                   name[6] == 'f')
9204               {                                   /* sprintf    */
9205                 return -KEY_sprintf;
9206               }
9207
9208               goto unknown;
9209
9210             case 'y':
9211               switch (name[2])
9212               {
9213                 case 'm':
9214                   if (name[3] == 'l' &&
9215                       name[4] == 'i' &&
9216                       name[5] == 'n' &&
9217                       name[6] == 'k')
9218                   {                               /* symlink    */
9219                     return -KEY_symlink;
9220                   }
9221
9222                   goto unknown;
9223
9224                 case 's':
9225                   switch (name[3])
9226                   {
9227                     case 'c':
9228                       if (name[4] == 'a' &&
9229                           name[5] == 'l' &&
9230                           name[6] == 'l')
9231                       {                           /* syscall    */
9232                         return -KEY_syscall;
9233                       }
9234
9235                       goto unknown;
9236
9237                     case 'o':
9238                       if (name[4] == 'p' &&
9239                           name[5] == 'e' &&
9240                           name[6] == 'n')
9241                       {                           /* sysopen    */
9242                         return -KEY_sysopen;
9243                       }
9244
9245                       goto unknown;
9246
9247                     case 'r':
9248                       if (name[4] == 'e' &&
9249                           name[5] == 'a' &&
9250                           name[6] == 'd')
9251                       {                           /* sysread    */
9252                         return -KEY_sysread;
9253                       }
9254
9255                       goto unknown;
9256
9257                     case 's':
9258                       if (name[4] == 'e' &&
9259                           name[5] == 'e' &&
9260                           name[6] == 'k')
9261                       {                           /* sysseek    */
9262                         return -KEY_sysseek;
9263                       }
9264
9265                       goto unknown;
9266
9267                     default:
9268                       goto unknown;
9269                   }
9270
9271                 default:
9272                   goto unknown;
9273               }
9274
9275             default:
9276               goto unknown;
9277           }
9278
9279         case 't':
9280           if (name[1] == 'e' &&
9281               name[2] == 'l' &&
9282               name[3] == 'l' &&
9283               name[4] == 'd' &&
9284               name[5] == 'i' &&
9285               name[6] == 'r')
9286           {                                       /* telldir    */
9287             return -KEY_telldir;
9288           }
9289
9290           goto unknown;
9291
9292         case 'u':
9293           switch (name[1])
9294           {
9295             case 'c':
9296               if (name[2] == 'f' &&
9297                   name[3] == 'i' &&
9298                   name[4] == 'r' &&
9299                   name[5] == 's' &&
9300                   name[6] == 't')
9301               {                                   /* ucfirst    */
9302                 return -KEY_ucfirst;
9303               }
9304
9305               goto unknown;
9306
9307             case 'n':
9308               if (name[2] == 's' &&
9309                   name[3] == 'h' &&
9310                   name[4] == 'i' &&
9311                   name[5] == 'f' &&
9312                   name[6] == 't')
9313               {                                   /* unshift    */
9314                 return -KEY_unshift;
9315               }
9316
9317               goto unknown;
9318
9319             default:
9320               goto unknown;
9321           }
9322
9323         case 'w':
9324           if (name[1] == 'a' &&
9325               name[2] == 'i' &&
9326               name[3] == 't' &&
9327               name[4] == 'p' &&
9328               name[5] == 'i' &&
9329               name[6] == 'd')
9330           {                                       /* waitpid    */
9331             return -KEY_waitpid;
9332           }
9333
9334           goto unknown;
9335
9336         default:
9337           goto unknown;
9338       }
9339
9340     case 8: /* 26 tokens of length 8 */
9341       switch (name[0])
9342       {
9343         case 'A':
9344           if (name[1] == 'U' &&
9345               name[2] == 'T' &&
9346               name[3] == 'O' &&
9347               name[4] == 'L' &&
9348               name[5] == 'O' &&
9349               name[6] == 'A' &&
9350               name[7] == 'D')
9351           {                                       /* AUTOLOAD   */
9352             return KEY_AUTOLOAD;
9353           }
9354
9355           goto unknown;
9356
9357         case '_':
9358           if (name[1] == '_')
9359           {
9360             switch (name[2])
9361             {
9362               case 'D':
9363                 if (name[3] == 'A' &&
9364                     name[4] == 'T' &&
9365                     name[5] == 'A' &&
9366                     name[6] == '_' &&
9367                     name[7] == '_')
9368                 {                                 /* __DATA__   */
9369                   return KEY___DATA__;
9370                 }
9371
9372                 goto unknown;
9373
9374               case 'F':
9375                 if (name[3] == 'I' &&
9376                     name[4] == 'L' &&
9377                     name[5] == 'E' &&
9378                     name[6] == '_' &&
9379                     name[7] == '_')
9380                 {                                 /* __FILE__   */
9381                   return -KEY___FILE__;
9382                 }
9383
9384                 goto unknown;
9385
9386               case 'L':
9387                 if (name[3] == 'I' &&
9388                     name[4] == 'N' &&
9389                     name[5] == 'E' &&
9390                     name[6] == '_' &&
9391                     name[7] == '_')
9392                 {                                 /* __LINE__   */
9393                   return -KEY___LINE__;
9394                 }
9395
9396                 goto unknown;
9397
9398               default:
9399                 goto unknown;
9400             }
9401           }
9402
9403           goto unknown;
9404
9405         case 'c':
9406           switch (name[1])
9407           {
9408             case 'l':
9409               if (name[2] == 'o' &&
9410                   name[3] == 's' &&
9411                   name[4] == 'e' &&
9412                   name[5] == 'd' &&
9413                   name[6] == 'i' &&
9414                   name[7] == 'r')
9415               {                                   /* closedir   */
9416                 return -KEY_closedir;
9417               }
9418
9419               goto unknown;
9420
9421             case 'o':
9422               if (name[2] == 'n' &&
9423                   name[3] == 't' &&
9424                   name[4] == 'i' &&
9425                   name[5] == 'n' &&
9426                   name[6] == 'u' &&
9427                   name[7] == 'e')
9428               {                                   /* continue   */
9429                 return -KEY_continue;
9430               }
9431
9432               goto unknown;
9433
9434             default:
9435               goto unknown;
9436           }
9437
9438         case 'd':
9439           if (name[1] == 'b' &&
9440               name[2] == 'm' &&
9441               name[3] == 'c' &&
9442               name[4] == 'l' &&
9443               name[5] == 'o' &&
9444               name[6] == 's' &&
9445               name[7] == 'e')
9446           {                                       /* dbmclose   */
9447             return -KEY_dbmclose;
9448           }
9449
9450           goto unknown;
9451
9452         case 'e':
9453           if (name[1] == 'n' &&
9454               name[2] == 'd')
9455           {
9456             switch (name[3])
9457             {
9458               case 'g':
9459                 if (name[4] == 'r' &&
9460                     name[5] == 'e' &&
9461                     name[6] == 'n' &&
9462                     name[7] == 't')
9463                 {                                 /* endgrent   */
9464                   return -KEY_endgrent;
9465                 }
9466
9467                 goto unknown;
9468
9469               case 'p':
9470                 if (name[4] == 'w' &&
9471                     name[5] == 'e' &&
9472                     name[6] == 'n' &&
9473                     name[7] == 't')
9474                 {                                 /* endpwent   */
9475                   return -KEY_endpwent;
9476                 }
9477
9478                 goto unknown;
9479
9480               default:
9481                 goto unknown;
9482             }
9483           }
9484
9485           goto unknown;
9486
9487         case 'f':
9488           if (name[1] == 'o' &&
9489               name[2] == 'r' &&
9490               name[3] == 'm' &&
9491               name[4] == 'l' &&
9492               name[5] == 'i' &&
9493               name[6] == 'n' &&
9494               name[7] == 'e')
9495           {                                       /* formline   */
9496             return -KEY_formline;
9497           }
9498
9499           goto unknown;
9500
9501         case 'g':
9502           if (name[1] == 'e' &&
9503               name[2] == 't')
9504           {
9505             switch (name[3])
9506             {
9507               case 'g':
9508                 if (name[4] == 'r')
9509                 {
9510                   switch (name[5])
9511                   {
9512                     case 'e':
9513                       if (name[6] == 'n' &&
9514                           name[7] == 't')
9515                       {                           /* getgrent   */
9516                         return -KEY_getgrent;
9517                       }
9518
9519                       goto unknown;
9520
9521                     case 'g':
9522                       if (name[6] == 'i' &&
9523                           name[7] == 'd')
9524                       {                           /* getgrgid   */
9525                         return -KEY_getgrgid;
9526                       }
9527
9528                       goto unknown;
9529
9530                     case 'n':
9531                       if (name[6] == 'a' &&
9532                           name[7] == 'm')
9533                       {                           /* getgrnam   */
9534                         return -KEY_getgrnam;
9535                       }
9536
9537                       goto unknown;
9538
9539                     default:
9540                       goto unknown;
9541                   }
9542                 }
9543
9544                 goto unknown;
9545
9546               case 'l':
9547                 if (name[4] == 'o' &&
9548                     name[5] == 'g' &&
9549                     name[6] == 'i' &&
9550                     name[7] == 'n')
9551                 {                                 /* getlogin   */
9552                   return -KEY_getlogin;
9553                 }
9554
9555                 goto unknown;
9556
9557               case 'p':
9558                 if (name[4] == 'w')
9559                 {
9560                   switch (name[5])
9561                   {
9562                     case 'e':
9563                       if (name[6] == 'n' &&
9564                           name[7] == 't')
9565                       {                           /* getpwent   */
9566                         return -KEY_getpwent;
9567                       }
9568
9569                       goto unknown;
9570
9571                     case 'n':
9572                       if (name[6] == 'a' &&
9573                           name[7] == 'm')
9574                       {                           /* getpwnam   */
9575                         return -KEY_getpwnam;
9576                       }
9577
9578                       goto unknown;
9579
9580                     case 'u':
9581                       if (name[6] == 'i' &&
9582                           name[7] == 'd')
9583                       {                           /* getpwuid   */
9584                         return -KEY_getpwuid;
9585                       }
9586
9587                       goto unknown;
9588
9589                     default:
9590                       goto unknown;
9591                   }
9592                 }
9593
9594                 goto unknown;
9595
9596               default:
9597                 goto unknown;
9598             }
9599           }
9600
9601           goto unknown;
9602
9603         case 'r':
9604           if (name[1] == 'e' &&
9605               name[2] == 'a' &&
9606               name[3] == 'd')
9607           {
9608             switch (name[4])
9609             {
9610               case 'l':
9611                 if (name[5] == 'i' &&
9612                     name[6] == 'n')
9613                 {
9614                   switch (name[7])
9615                   {
9616                     case 'e':
9617                       {                           /* readline   */
9618                         return -KEY_readline;
9619                       }
9620
9621                     case 'k':
9622                       {                           /* readlink   */
9623                         return -KEY_readlink;
9624                       }
9625
9626                     default:
9627                       goto unknown;
9628                   }
9629                 }
9630
9631                 goto unknown;
9632
9633               case 'p':
9634                 if (name[5] == 'i' &&
9635                     name[6] == 'p' &&
9636                     name[7] == 'e')
9637                 {                                 /* readpipe   */
9638                   return -KEY_readpipe;
9639                 }
9640
9641                 goto unknown;
9642
9643               default:
9644                 goto unknown;
9645             }
9646           }
9647
9648           goto unknown;
9649
9650         case 's':
9651           switch (name[1])
9652           {
9653             case 'e':
9654               if (name[2] == 't')
9655               {
9656                 switch (name[3])
9657                 {
9658                   case 'g':
9659                     if (name[4] == 'r' &&
9660                         name[5] == 'e' &&
9661                         name[6] == 'n' &&
9662                         name[7] == 't')
9663                     {                             /* setgrent   */
9664                       return -KEY_setgrent;
9665                     }
9666
9667                     goto unknown;
9668
9669                   case 'p':
9670                     if (name[4] == 'w' &&
9671                         name[5] == 'e' &&
9672                         name[6] == 'n' &&
9673                         name[7] == 't')
9674                     {                             /* setpwent   */
9675                       return -KEY_setpwent;
9676                     }
9677
9678                     goto unknown;
9679
9680                   default:
9681                     goto unknown;
9682                 }
9683               }
9684
9685               goto unknown;
9686
9687             case 'h':
9688               switch (name[2])
9689               {
9690                 case 'm':
9691                   if (name[3] == 'w' &&
9692                       name[4] == 'r' &&
9693                       name[5] == 'i' &&
9694                       name[6] == 't' &&
9695                       name[7] == 'e')
9696                   {                               /* shmwrite   */
9697                     return -KEY_shmwrite;
9698                   }
9699
9700                   goto unknown;
9701
9702                 case 'u':
9703                   if (name[3] == 't' &&
9704                       name[4] == 'd' &&
9705                       name[5] == 'o' &&
9706                       name[6] == 'w' &&
9707                       name[7] == 'n')
9708                   {                               /* shutdown   */
9709                     return -KEY_shutdown;
9710                   }
9711
9712                   goto unknown;
9713
9714                 default:
9715                   goto unknown;
9716               }
9717
9718             case 'y':
9719               if (name[2] == 's' &&
9720                   name[3] == 'w' &&
9721                   name[4] == 'r' &&
9722                   name[5] == 'i' &&
9723                   name[6] == 't' &&
9724                   name[7] == 'e')
9725               {                                   /* syswrite   */
9726                 return -KEY_syswrite;
9727               }
9728
9729               goto unknown;
9730
9731             default:
9732               goto unknown;
9733           }
9734
9735         case 't':
9736           if (name[1] == 'r' &&
9737               name[2] == 'u' &&
9738               name[3] == 'n' &&
9739               name[4] == 'c' &&
9740               name[5] == 'a' &&
9741               name[6] == 't' &&
9742               name[7] == 'e')
9743           {                                       /* truncate   */
9744             return -KEY_truncate;
9745           }
9746
9747           goto unknown;
9748
9749         default:
9750           goto unknown;
9751       }
9752
9753     case 9: /* 9 tokens of length 9 */
9754       switch (name[0])
9755       {
9756         case 'U':
9757           if (name[1] == 'N' &&
9758               name[2] == 'I' &&
9759               name[3] == 'T' &&
9760               name[4] == 'C' &&
9761               name[5] == 'H' &&
9762               name[6] == 'E' &&
9763               name[7] == 'C' &&
9764               name[8] == 'K')
9765           {                                       /* UNITCHECK  */
9766             return KEY_UNITCHECK;
9767           }
9768
9769           goto unknown;
9770
9771         case 'e':
9772           if (name[1] == 'n' &&
9773               name[2] == 'd' &&
9774               name[3] == 'n' &&
9775               name[4] == 'e' &&
9776               name[5] == 't' &&
9777               name[6] == 'e' &&
9778               name[7] == 'n' &&
9779               name[8] == 't')
9780           {                                       /* endnetent  */
9781             return -KEY_endnetent;
9782           }
9783
9784           goto unknown;
9785
9786         case 'g':
9787           if (name[1] == 'e' &&
9788               name[2] == 't' &&
9789               name[3] == 'n' &&
9790               name[4] == 'e' &&
9791               name[5] == 't' &&
9792               name[6] == 'e' &&
9793               name[7] == 'n' &&
9794               name[8] == 't')
9795           {                                       /* getnetent  */
9796             return -KEY_getnetent;
9797           }
9798
9799           goto unknown;
9800
9801         case 'l':
9802           if (name[1] == 'o' &&
9803               name[2] == 'c' &&
9804               name[3] == 'a' &&
9805               name[4] == 'l' &&
9806               name[5] == 't' &&
9807               name[6] == 'i' &&
9808               name[7] == 'm' &&
9809               name[8] == 'e')
9810           {                                       /* localtime  */
9811             return -KEY_localtime;
9812           }
9813
9814           goto unknown;
9815
9816         case 'p':
9817           if (name[1] == 'r' &&
9818               name[2] == 'o' &&
9819               name[3] == 't' &&
9820               name[4] == 'o' &&
9821               name[5] == 't' &&
9822               name[6] == 'y' &&
9823               name[7] == 'p' &&
9824               name[8] == 'e')
9825           {                                       /* prototype  */
9826             return KEY_prototype;
9827           }
9828
9829           goto unknown;
9830
9831         case 'q':
9832           if (name[1] == 'u' &&
9833               name[2] == 'o' &&
9834               name[3] == 't' &&
9835               name[4] == 'e' &&
9836               name[5] == 'm' &&
9837               name[6] == 'e' &&
9838               name[7] == 't' &&
9839               name[8] == 'a')
9840           {                                       /* quotemeta  */
9841             return -KEY_quotemeta;
9842           }
9843
9844           goto unknown;
9845
9846         case 'r':
9847           if (name[1] == 'e' &&
9848               name[2] == 'w' &&
9849               name[3] == 'i' &&
9850               name[4] == 'n' &&
9851               name[5] == 'd' &&
9852               name[6] == 'd' &&
9853               name[7] == 'i' &&
9854               name[8] == 'r')
9855           {                                       /* rewinddir  */
9856             return -KEY_rewinddir;
9857           }
9858
9859           goto unknown;
9860
9861         case 's':
9862           if (name[1] == 'e' &&
9863               name[2] == 't' &&
9864               name[3] == 'n' &&
9865               name[4] == 'e' &&
9866               name[5] == 't' &&
9867               name[6] == 'e' &&
9868               name[7] == 'n' &&
9869               name[8] == 't')
9870           {                                       /* setnetent  */
9871             return -KEY_setnetent;
9872           }
9873
9874           goto unknown;
9875
9876         case 'w':
9877           if (name[1] == 'a' &&
9878               name[2] == 'n' &&
9879               name[3] == 't' &&
9880               name[4] == 'a' &&
9881               name[5] == 'r' &&
9882               name[6] == 'r' &&
9883               name[7] == 'a' &&
9884               name[8] == 'y')
9885           {                                       /* wantarray  */
9886             return -KEY_wantarray;
9887           }
9888
9889           goto unknown;
9890
9891         default:
9892           goto unknown;
9893       }
9894
9895     case 10: /* 9 tokens of length 10 */
9896       switch (name[0])
9897       {
9898         case 'e':
9899           if (name[1] == 'n' &&
9900               name[2] == 'd')
9901           {
9902             switch (name[3])
9903             {
9904               case 'h':
9905                 if (name[4] == 'o' &&
9906                     name[5] == 's' &&
9907                     name[6] == 't' &&
9908                     name[7] == 'e' &&
9909                     name[8] == 'n' &&
9910                     name[9] == 't')
9911                 {                                 /* endhostent */
9912                   return -KEY_endhostent;
9913                 }
9914
9915                 goto unknown;
9916
9917               case 's':
9918                 if (name[4] == 'e' &&
9919                     name[5] == 'r' &&
9920                     name[6] == 'v' &&
9921                     name[7] == 'e' &&
9922                     name[8] == 'n' &&
9923                     name[9] == 't')
9924                 {                                 /* endservent */
9925                   return -KEY_endservent;
9926                 }
9927
9928                 goto unknown;
9929
9930               default:
9931                 goto unknown;
9932             }
9933           }
9934
9935           goto unknown;
9936
9937         case 'g':
9938           if (name[1] == 'e' &&
9939               name[2] == 't')
9940           {
9941             switch (name[3])
9942             {
9943               case 'h':
9944                 if (name[4] == 'o' &&
9945                     name[5] == 's' &&
9946                     name[6] == 't' &&
9947                     name[7] == 'e' &&
9948                     name[8] == 'n' &&
9949                     name[9] == 't')
9950                 {                                 /* gethostent */
9951                   return -KEY_gethostent;
9952                 }
9953
9954                 goto unknown;
9955
9956               case 's':
9957                 switch (name[4])
9958                 {
9959                   case 'e':
9960                     if (name[5] == 'r' &&
9961                         name[6] == 'v' &&
9962                         name[7] == 'e' &&
9963                         name[8] == 'n' &&
9964                         name[9] == 't')
9965                     {                             /* getservent */
9966                       return -KEY_getservent;
9967                     }
9968
9969                     goto unknown;
9970
9971                   case 'o':
9972                     if (name[5] == 'c' &&
9973                         name[6] == 'k' &&
9974                         name[7] == 'o' &&
9975                         name[8] == 'p' &&
9976                         name[9] == 't')
9977                     {                             /* getsockopt */
9978                       return -KEY_getsockopt;
9979                     }
9980
9981                     goto unknown;
9982
9983                   default:
9984                     goto unknown;
9985                 }
9986
9987               default:
9988                 goto unknown;
9989             }
9990           }
9991
9992           goto unknown;
9993
9994         case 's':
9995           switch (name[1])
9996           {
9997             case 'e':
9998               if (name[2] == 't')
9999               {
10000                 switch (name[3])
10001                 {
10002                   case 'h':
10003                     if (name[4] == 'o' &&
10004                         name[5] == 's' &&
10005                         name[6] == 't' &&
10006                         name[7] == 'e' &&
10007                         name[8] == 'n' &&
10008                         name[9] == 't')
10009                     {                             /* sethostent */
10010                       return -KEY_sethostent;
10011                     }
10012
10013                     goto unknown;
10014
10015                   case 's':
10016                     switch (name[4])
10017                     {
10018                       case 'e':
10019                         if (name[5] == 'r' &&
10020                             name[6] == 'v' &&
10021                             name[7] == 'e' &&
10022                             name[8] == 'n' &&
10023                             name[9] == 't')
10024                         {                         /* setservent */
10025                           return -KEY_setservent;
10026                         }
10027
10028                         goto unknown;
10029
10030                       case 'o':
10031                         if (name[5] == 'c' &&
10032                             name[6] == 'k' &&
10033                             name[7] == 'o' &&
10034                             name[8] == 'p' &&
10035                             name[9] == 't')
10036                         {                         /* setsockopt */
10037                           return -KEY_setsockopt;
10038                         }
10039
10040                         goto unknown;
10041
10042                       default:
10043                         goto unknown;
10044                     }
10045
10046                   default:
10047                     goto unknown;
10048                 }
10049               }
10050
10051               goto unknown;
10052
10053             case 'o':
10054               if (name[2] == 'c' &&
10055                   name[3] == 'k' &&
10056                   name[4] == 'e' &&
10057                   name[5] == 't' &&
10058                   name[6] == 'p' &&
10059                   name[7] == 'a' &&
10060                   name[8] == 'i' &&
10061                   name[9] == 'r')
10062               {                                   /* socketpair */
10063                 return -KEY_socketpair;
10064               }
10065
10066               goto unknown;
10067
10068             default:
10069               goto unknown;
10070           }
10071
10072         default:
10073           goto unknown;
10074       }
10075
10076     case 11: /* 8 tokens of length 11 */
10077       switch (name[0])
10078       {
10079         case '_':
10080           if (name[1] == '_' &&
10081               name[2] == 'P' &&
10082               name[3] == 'A' &&
10083               name[4] == 'C' &&
10084               name[5] == 'K' &&
10085               name[6] == 'A' &&
10086               name[7] == 'G' &&
10087               name[8] == 'E' &&
10088               name[9] == '_' &&
10089               name[10] == '_')
10090           {                                       /* __PACKAGE__ */
10091             return -KEY___PACKAGE__;
10092           }
10093
10094           goto unknown;
10095
10096         case 'e':
10097           if (name[1] == 'n' &&
10098               name[2] == 'd' &&
10099               name[3] == 'p' &&
10100               name[4] == 'r' &&
10101               name[5] == 'o' &&
10102               name[6] == 't' &&
10103               name[7] == 'o' &&
10104               name[8] == 'e' &&
10105               name[9] == 'n' &&
10106               name[10] == 't')
10107           {                                       /* endprotoent */
10108             return -KEY_endprotoent;
10109           }
10110
10111           goto unknown;
10112
10113         case 'g':
10114           if (name[1] == 'e' &&
10115               name[2] == 't')
10116           {
10117             switch (name[3])
10118             {
10119               case 'p':
10120                 switch (name[4])
10121                 {
10122                   case 'e':
10123                     if (name[5] == 'e' &&
10124                         name[6] == 'r' &&
10125                         name[7] == 'n' &&
10126                         name[8] == 'a' &&
10127                         name[9] == 'm' &&
10128                         name[10] == 'e')
10129                     {                             /* getpeername */
10130                       return -KEY_getpeername;
10131                     }
10132
10133                     goto unknown;
10134
10135                   case 'r':
10136                     switch (name[5])
10137                     {
10138                       case 'i':
10139                         if (name[6] == 'o' &&
10140                             name[7] == 'r' &&
10141                             name[8] == 'i' &&
10142                             name[9] == 't' &&
10143                             name[10] == 'y')
10144                         {                         /* getpriority */
10145                           return -KEY_getpriority;
10146                         }
10147
10148                         goto unknown;
10149
10150                       case 'o':
10151                         if (name[6] == 't' &&
10152                             name[7] == 'o' &&
10153                             name[8] == 'e' &&
10154                             name[9] == 'n' &&
10155                             name[10] == 't')
10156                         {                         /* getprotoent */
10157                           return -KEY_getprotoent;
10158                         }
10159
10160                         goto unknown;
10161
10162                       default:
10163                         goto unknown;
10164                     }
10165
10166                   default:
10167                     goto unknown;
10168                 }
10169
10170               case 's':
10171                 if (name[4] == 'o' &&
10172                     name[5] == 'c' &&
10173                     name[6] == 'k' &&
10174                     name[7] == 'n' &&
10175                     name[8] == 'a' &&
10176                     name[9] == 'm' &&
10177                     name[10] == 'e')
10178                 {                                 /* getsockname */
10179                   return -KEY_getsockname;
10180                 }
10181
10182                 goto unknown;
10183
10184               default:
10185                 goto unknown;
10186             }
10187           }
10188
10189           goto unknown;
10190
10191         case 's':
10192           if (name[1] == 'e' &&
10193               name[2] == 't' &&
10194               name[3] == 'p' &&
10195               name[4] == 'r')
10196           {
10197             switch (name[5])
10198             {
10199               case 'i':
10200                 if (name[6] == 'o' &&
10201                     name[7] == 'r' &&
10202                     name[8] == 'i' &&
10203                     name[9] == 't' &&
10204                     name[10] == 'y')
10205                 {                                 /* setpriority */
10206                   return -KEY_setpriority;
10207                 }
10208
10209                 goto unknown;
10210
10211               case 'o':
10212                 if (name[6] == 't' &&
10213                     name[7] == 'o' &&
10214                     name[8] == 'e' &&
10215                     name[9] == 'n' &&
10216                     name[10] == 't')
10217                 {                                 /* setprotoent */
10218                   return -KEY_setprotoent;
10219                 }
10220
10221                 goto unknown;
10222
10223               default:
10224                 goto unknown;
10225             }
10226           }
10227
10228           goto unknown;
10229
10230         default:
10231           goto unknown;
10232       }
10233
10234     case 12: /* 2 tokens of length 12 */
10235       if (name[0] == 'g' &&
10236           name[1] == 'e' &&
10237           name[2] == 't' &&
10238           name[3] == 'n' &&
10239           name[4] == 'e' &&
10240           name[5] == 't' &&
10241           name[6] == 'b' &&
10242           name[7] == 'y')
10243       {
10244         switch (name[8])
10245         {
10246           case 'a':
10247             if (name[9] == 'd' &&
10248                 name[10] == 'd' &&
10249                 name[11] == 'r')
10250             {                                     /* getnetbyaddr */
10251               return -KEY_getnetbyaddr;
10252             }
10253
10254             goto unknown;
10255
10256           case 'n':
10257             if (name[9] == 'a' &&
10258                 name[10] == 'm' &&
10259                 name[11] == 'e')
10260             {                                     /* getnetbyname */
10261               return -KEY_getnetbyname;
10262             }
10263
10264             goto unknown;
10265
10266           default:
10267             goto unknown;
10268         }
10269       }
10270
10271       goto unknown;
10272
10273     case 13: /* 4 tokens of length 13 */
10274       if (name[0] == 'g' &&
10275           name[1] == 'e' &&
10276           name[2] == 't')
10277       {
10278         switch (name[3])
10279         {
10280           case 'h':
10281             if (name[4] == 'o' &&
10282                 name[5] == 's' &&
10283                 name[6] == 't' &&
10284                 name[7] == 'b' &&
10285                 name[8] == 'y')
10286             {
10287               switch (name[9])
10288               {
10289                 case 'a':
10290                   if (name[10] == 'd' &&
10291                       name[11] == 'd' &&
10292                       name[12] == 'r')
10293                   {                               /* gethostbyaddr */
10294                     return -KEY_gethostbyaddr;
10295                   }
10296
10297                   goto unknown;
10298
10299                 case 'n':
10300                   if (name[10] == 'a' &&
10301                       name[11] == 'm' &&
10302                       name[12] == 'e')
10303                   {                               /* gethostbyname */
10304                     return -KEY_gethostbyname;
10305                   }
10306
10307                   goto unknown;
10308
10309                 default:
10310                   goto unknown;
10311               }
10312             }
10313
10314             goto unknown;
10315
10316           case 's':
10317             if (name[4] == 'e' &&
10318                 name[5] == 'r' &&
10319                 name[6] == 'v' &&
10320                 name[7] == 'b' &&
10321                 name[8] == 'y')
10322             {
10323               switch (name[9])
10324               {
10325                 case 'n':
10326                   if (name[10] == 'a' &&
10327                       name[11] == 'm' &&
10328                       name[12] == 'e')
10329                   {                               /* getservbyname */
10330                     return -KEY_getservbyname;
10331                   }
10332
10333                   goto unknown;
10334
10335                 case 'p':
10336                   if (name[10] == 'o' &&
10337                       name[11] == 'r' &&
10338                       name[12] == 't')
10339                   {                               /* getservbyport */
10340                     return -KEY_getservbyport;
10341                   }
10342
10343                   goto unknown;
10344
10345                 default:
10346                   goto unknown;
10347               }
10348             }
10349
10350             goto unknown;
10351
10352           default:
10353             goto unknown;
10354         }
10355       }
10356
10357       goto unknown;
10358
10359     case 14: /* 1 tokens of length 14 */
10360       if (name[0] == 'g' &&
10361           name[1] == 'e' &&
10362           name[2] == 't' &&
10363           name[3] == 'p' &&
10364           name[4] == 'r' &&
10365           name[5] == 'o' &&
10366           name[6] == 't' &&
10367           name[7] == 'o' &&
10368           name[8] == 'b' &&
10369           name[9] == 'y' &&
10370           name[10] == 'n' &&
10371           name[11] == 'a' &&
10372           name[12] == 'm' &&
10373           name[13] == 'e')
10374       {                                           /* getprotobyname */
10375         return -KEY_getprotobyname;
10376       }
10377
10378       goto unknown;
10379
10380     case 16: /* 1 tokens of length 16 */
10381       if (name[0] == 'g' &&
10382           name[1] == 'e' &&
10383           name[2] == 't' &&
10384           name[3] == 'p' &&
10385           name[4] == 'r' &&
10386           name[5] == 'o' &&
10387           name[6] == 't' &&
10388           name[7] == 'o' &&
10389           name[8] == 'b' &&
10390           name[9] == 'y' &&
10391           name[10] == 'n' &&
10392           name[11] == 'u' &&
10393           name[12] == 'm' &&
10394           name[13] == 'b' &&
10395           name[14] == 'e' &&
10396           name[15] == 'r')
10397       {                                           /* getprotobynumber */
10398         return -KEY_getprotobynumber;
10399       }
10400
10401       goto unknown;
10402
10403     default:
10404       goto unknown;
10405   }
10406
10407 unknown:
10408   return 0;
10409 }
10410
10411 STATIC void
10412 S_checkcomma(pTHX_ const char *s, const char *name, const char *what)
10413 {
10414     dVAR;
10415
10416     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
10417         if (ckWARN(WARN_SYNTAX)) {
10418             int level = 1;
10419             const char *w;
10420             for (w = s+2; *w && level; w++) {
10421                 if (*w == '(')
10422                     ++level;
10423                 else if (*w == ')')
10424                     --level;
10425             }
10426             while (isSPACE(*w))
10427                 ++w;
10428             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
10429                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
10430                             "%s (...) interpreted as function",name);
10431         }
10432     }
10433     while (s < PL_bufend && isSPACE(*s))
10434         s++;
10435     if (*s == '(')
10436         s++;
10437     while (s < PL_bufend && isSPACE(*s))
10438         s++;
10439     if (isIDFIRST_lazy_if(s,UTF)) {
10440         const char * const w = s++;
10441         while (isALNUM_lazy_if(s,UTF))
10442             s++;
10443         while (s < PL_bufend && isSPACE(*s))
10444             s++;
10445         if (*s == ',') {
10446             GV* gv;
10447             if (keyword(w, s - w, 0))
10448                 return;
10449
10450             gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV);
10451             if (gv && GvCVu(gv))
10452                 return;
10453             Perl_croak(aTHX_ "No comma allowed after %s", what);
10454         }
10455     }
10456 }
10457
10458 /* Either returns sv, or mortalizes sv and returns a new SV*.
10459    Best used as sv=new_constant(..., sv, ...).
10460    If s, pv are NULL, calls subroutine with one argument,
10461    and type is used with error messages only. */
10462
10463 STATIC SV *
10464 S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv,
10465                const char *type)
10466 {
10467     dVAR; dSP;
10468     HV * const table = GvHV(PL_hintgv);          /* ^H */
10469     SV *res;
10470     SV **cvp;
10471     SV *cv, *typesv;
10472     const char *why1 = "", *why2 = "", *why3 = "";
10473
10474     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
10475         SV *msg;
10476
10477         why2 = (const char *)
10478             (strEQ(key,"charnames")
10479              ? "(possibly a missing \"use charnames ...\")"
10480              : "");
10481         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
10482                             (type ? type: "undef"), why2);
10483
10484         /* This is convoluted and evil ("goto considered harmful")
10485          * but I do not understand the intricacies of all the different
10486          * failure modes of %^H in here.  The goal here is to make
10487          * the most probable error message user-friendly. --jhi */
10488
10489         goto msgdone;
10490
10491     report:
10492         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
10493                             (type ? type: "undef"), why1, why2, why3);
10494     msgdone:
10495         yyerror(SvPVX_const(msg));
10496         SvREFCNT_dec(msg);
10497         return sv;
10498     }
10499     cvp = hv_fetch(table, key, strlen(key), FALSE);
10500     if (!cvp || !SvOK(*cvp)) {
10501         why1 = "$^H{";
10502         why2 = key;
10503         why3 = "} is not defined";
10504         goto report;
10505     }
10506     sv_2mortal(sv);                     /* Parent created it permanently */
10507     cv = *cvp;
10508     if (!pv && s)
10509         pv = sv_2mortal(newSVpvn(s, len));
10510     if (type && pv)
10511         typesv = sv_2mortal(newSVpv(type, 0));
10512     else
10513         typesv = &PL_sv_undef;
10514
10515     PUSHSTACKi(PERLSI_OVERLOAD);
10516     ENTER ;
10517     SAVETMPS;
10518
10519     PUSHMARK(SP) ;
10520     EXTEND(sp, 3);
10521     if (pv)
10522         PUSHs(pv);
10523     PUSHs(sv);
10524     if (pv)
10525         PUSHs(typesv);
10526     PUTBACK;
10527     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
10528
10529     SPAGAIN ;
10530
10531     /* Check the eval first */
10532     if (!PL_in_eval && SvTRUE(ERRSV)) {
10533         sv_catpvs(ERRSV, "Propagated");
10534         yyerror(SvPV_nolen_const(ERRSV)); /* Duplicates the message inside eval */
10535         (void)POPs;
10536         res = SvREFCNT_inc_simple(sv);
10537     }
10538     else {
10539         res = POPs;
10540         SvREFCNT_inc_simple_void(res);
10541     }
10542
10543     PUTBACK ;
10544     FREETMPS ;
10545     LEAVE ;
10546     POPSTACK;
10547
10548     if (!SvOK(res)) {
10549         why1 = "Call to &{$^H{";
10550         why2 = key;
10551         why3 = "}} did not return a defined value";
10552         sv = res;
10553         goto report;
10554     }
10555
10556     return res;
10557 }
10558
10559 /* Returns a NUL terminated string, with the length of the string written to
10560    *slp
10561    */
10562 STATIC char *
10563 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
10564 {
10565     dVAR;
10566     register char *d = dest;
10567     register char * const e = d + destlen - 3;  /* two-character token, ending NUL */
10568     for (;;) {
10569         if (d >= e)
10570             Perl_croak(aTHX_ ident_too_long);
10571         if (isALNUM(*s))        /* UTF handled below */
10572             *d++ = *s++;
10573         else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) {
10574             *d++ = ':';
10575             *d++ = ':';
10576             s++;
10577         }
10578         else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) {
10579             *d++ = *s++;
10580             *d++ = *s++;
10581         }
10582         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10583             char *t = s + UTF8SKIP(s);
10584             size_t len;
10585             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10586                 t += UTF8SKIP(t);
10587             len = t - s;
10588             if (d + len > e)
10589                 Perl_croak(aTHX_ ident_too_long);
10590             Copy(s, d, len, char);
10591             d += len;
10592             s = t;
10593         }
10594         else {
10595             *d = '\0';
10596             *slp = d - dest;
10597             return s;
10598         }
10599     }
10600 }
10601
10602 STATIC char *
10603 S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRLEN destlen, I32 ck_uni)
10604 {
10605     dVAR;
10606     char *bracket = NULL;
10607     char funny = *s++;
10608     register char *d = dest;
10609     register char * const e = d + destlen + 3;    /* two-character token, ending NUL */
10610
10611     if (isSPACE(*s))
10612         s = PEEKSPACE(s);
10613     if (isDIGIT(*s)) {
10614         while (isDIGIT(*s)) {
10615             if (d >= e)
10616                 Perl_croak(aTHX_ ident_too_long);
10617             *d++ = *s++;
10618         }
10619     }
10620     else {
10621         for (;;) {
10622             if (d >= e)
10623                 Perl_croak(aTHX_ ident_too_long);
10624             if (isALNUM(*s))    /* UTF handled below */
10625                 *d++ = *s++;
10626             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
10627                 *d++ = ':';
10628                 *d++ = ':';
10629                 s++;
10630             }
10631             else if (*s == ':' && s[1] == ':') {
10632                 *d++ = *s++;
10633                 *d++ = *s++;
10634             }
10635             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
10636                 char *t = s + UTF8SKIP(s);
10637                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
10638                     t += UTF8SKIP(t);
10639                 if (d + (t - s) > e)
10640                     Perl_croak(aTHX_ ident_too_long);
10641                 Copy(s, d, t - s, char);
10642                 d += t - s;
10643                 s = t;
10644             }
10645             else
10646                 break;
10647         }
10648     }
10649     *d = '\0';
10650     d = dest;
10651     if (*d) {
10652         if (PL_lex_state != LEX_NORMAL)
10653             PL_lex_state = LEX_INTERPENDMAYBE;
10654         return s;
10655     }
10656     if (*s == '$' && s[1] &&
10657         (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) )
10658     {
10659         return s;
10660     }
10661     if (*s == '{') {
10662         bracket = s;
10663         s++;
10664     }
10665     else if (ck_uni)
10666         check_uni();
10667     if (s < send)
10668         *d = *s++;
10669     d[1] = '\0';
10670     if (*d == '^' && *s && isCONTROLVAR(*s)) {
10671         *d = toCTRL(*s);
10672         s++;
10673     }
10674     if (bracket) {
10675         if (isSPACE(s[-1])) {
10676             while (s < send) {
10677                 const char ch = *s++;
10678                 if (!SPACE_OR_TAB(ch)) {
10679                     *d = ch;
10680                     break;
10681                 }
10682             }
10683         }
10684         if (isIDFIRST_lazy_if(d,UTF)) {
10685             d++;
10686             if (UTF) {
10687                 char *end = s;
10688                 while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
10689                     end += UTF8SKIP(end);
10690                     while (end < send && UTF8_IS_CONTINUED(*end) && is_utf8_mark((U8*)end))
10691                         end += UTF8SKIP(end);
10692                 }
10693                 Copy(s, d, end - s, char);
10694                 d += end - s;
10695                 s = end;
10696             }
10697             else {
10698                 while ((isALNUM(*s) || *s == ':') && d < e)
10699                     *d++ = *s++;
10700                 if (d >= e)
10701                     Perl_croak(aTHX_ ident_too_long);
10702             }
10703             *d = '\0';
10704             while (s < send && SPACE_OR_TAB(*s))
10705                 s++;
10706             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
10707                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) {
10708                     const char * const brack =
10709                         (const char *)
10710                         ((*s == '[') ? "[...]" : "{...}");
10711                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10712                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
10713                         funny, dest, brack, funny, dest, brack);
10714                 }
10715                 bracket++;
10716                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
10717                 return s;
10718             }
10719         }
10720         /* Handle extended ${^Foo} variables
10721          * 1999-02-27 mjd-perl-patch@plover.com */
10722         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
10723                  && isALNUM(*s))
10724         {
10725             d++;
10726             while (isALNUM(*s) && d < e) {
10727                 *d++ = *s++;
10728             }
10729             if (d >= e)
10730                 Perl_croak(aTHX_ ident_too_long);
10731             *d = '\0';
10732         }
10733         if (*s == '}') {
10734             s++;
10735             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
10736                 PL_lex_state = LEX_INTERPEND;
10737                 PL_expect = XREF;
10738             }
10739             if (PL_lex_state == LEX_NORMAL) {
10740                 if (ckWARN(WARN_AMBIGUOUS) &&
10741                     (keyword(dest, d - dest, 0) || get_cv(dest, FALSE)))
10742                 {
10743                     if (funny == '#')
10744                         funny = '@';
10745                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
10746                         "Ambiguous use of %c{%s} resolved to %c%s",
10747                         funny, dest, funny, dest);
10748                 }
10749             }
10750         }
10751         else {
10752             s = bracket;                /* let the parser handle it */
10753             *dest = '\0';
10754         }
10755     }
10756     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
10757         PL_lex_state = LEX_INTERPEND;
10758     return s;
10759 }
10760
10761 void
10762 Perl_pmflag(pTHX_ U32* pmfl, int ch)
10763 {
10764     PERL_UNUSED_CONTEXT;
10765     if (ch == 'i')
10766         *pmfl |= PMf_FOLD;
10767     else if (ch == 'g')
10768         *pmfl |= PMf_GLOBAL;
10769     else if (ch == 'c')
10770         *pmfl |= PMf_CONTINUE;
10771     else if (ch == 'o')
10772         *pmfl |= PMf_KEEP;
10773     else if (ch == 'm')
10774         *pmfl |= PMf_MULTILINE;
10775     else if (ch == 's')
10776         *pmfl |= PMf_SINGLELINE;
10777     else if (ch == 'x')
10778         *pmfl |= PMf_EXTENDED;
10779 }
10780
10781 STATIC char *
10782 S_scan_pat(pTHX_ char *start, I32 type)
10783 {
10784     dVAR;
10785     PMOP *pm;
10786     char *s = scan_str(start,!!PL_madskills,FALSE);
10787     const char * const valid_flags =
10788         (const char *)((type == OP_QR) ? "iomsx" : "iogcmsx");
10789 #ifdef PERL_MAD
10790     char *modstart;
10791 #endif
10792
10793
10794     if (!s) {
10795         const char * const delimiter = skipspace(start);
10796         Perl_croak(aTHX_
10797                    (const char *)
10798                    (*delimiter == '?'
10799                     ? "Search pattern not terminated or ternary operator parsed as search pattern"
10800                     : "Search pattern not terminated" ));
10801     }
10802
10803     pm = (PMOP*)newPMOP(type, 0);
10804     if (PL_multi_open == '?')
10805         pm->op_pmflags |= PMf_ONCE;
10806 #ifdef PERL_MAD
10807     modstart = s;
10808 #endif
10809     while (*s && strchr(valid_flags, *s))
10810         pmflag(&pm->op_pmflags,*s++);
10811 #ifdef PERL_MAD
10812     if (PL_madskills && modstart != s) {
10813         SV* tmptoken = newSVpvn(modstart, s - modstart);
10814         append_madprops(newMADPROP('m', MAD_SV, tmptoken, 0), (OP*)pm, 0);
10815     }
10816 #endif
10817     /* issue a warning if /c is specified,but /g is not */
10818     if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
10819             && ckWARN(WARN_REGEXP))
10820     {
10821         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" );
10822     }
10823
10824     pm->op_pmpermflags = pm->op_pmflags;
10825
10826     PL_lex_op = (OP*)pm;
10827     yylval.ival = OP_MATCH;
10828     return s;
10829 }
10830
10831 STATIC char *
10832 S_scan_subst(pTHX_ char *start)
10833 {
10834     dVAR;
10835     register char *s;
10836     register PMOP *pm;
10837     I32 first_start;
10838     I32 es = 0;
10839 #ifdef PERL_MAD
10840     char *modstart;
10841 #endif
10842
10843     yylval.ival = OP_NULL;
10844
10845     s = scan_str(start,!!PL_madskills,FALSE);
10846
10847     if (!s)
10848         Perl_croak(aTHX_ "Substitution pattern not terminated");
10849
10850     if (s[-1] == PL_multi_open)
10851         s--;
10852 #ifdef PERL_MAD
10853     if (PL_madskills) {
10854         CURMAD('q', PL_thisopen);
10855         CURMAD('_', PL_thiswhite);
10856         CURMAD('E', PL_thisstuff);
10857         CURMAD('Q', PL_thisclose);
10858         PL_realtokenstart = s - SvPVX(PL_linestr);
10859     }
10860 #endif
10861
10862     first_start = PL_multi_start;
10863     s = scan_str(s,!!PL_madskills,FALSE);
10864     if (!s) {
10865         if (PL_lex_stuff) {
10866             SvREFCNT_dec(PL_lex_stuff);
10867             PL_lex_stuff = NULL;
10868         }
10869         Perl_croak(aTHX_ "Substitution replacement not terminated");
10870     }
10871     PL_multi_start = first_start;       /* so whole substitution is taken together */
10872
10873     pm = (PMOP*)newPMOP(OP_SUBST, 0);
10874
10875 #ifdef PERL_MAD
10876     if (PL_madskills) {
10877         CURMAD('z', PL_thisopen);
10878         CURMAD('R', PL_thisstuff);
10879         CURMAD('Z', PL_thisclose);
10880     }
10881     modstart = s;
10882 #endif
10883
10884     while (*s) {
10885         if (*s == 'e') {
10886             s++;
10887             es++;
10888         }
10889         else if (strchr("iogcmsx", *s))
10890             pmflag(&pm->op_pmflags,*s++);
10891         else
10892             break;
10893     }
10894
10895 #ifdef PERL_MAD
10896     if (PL_madskills) {
10897         if (modstart != s)
10898             curmad('m', newSVpvn(modstart, s - modstart));
10899         append_madprops(PL_thismad, (OP*)pm, 0);
10900         PL_thismad = 0;
10901     }
10902 #endif
10903     if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP)) {
10904         Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless in s///" );
10905     }
10906
10907     if (es) {
10908         SV * const repl = newSVpvs("");
10909
10910         PL_sublex_info.super_bufptr = s;
10911         PL_sublex_info.super_bufend = PL_bufend;
10912         PL_multi_end = 0;
10913         pm->op_pmflags |= PMf_EVAL;
10914         while (es-- > 0)
10915             sv_catpv(repl, (const char *)(es ? "eval " : "do "));
10916         sv_catpvs(repl, "{");
10917         sv_catsv(repl, PL_lex_repl);
10918         if (strchr(SvPVX(PL_lex_repl), '#'))
10919             sv_catpvs(repl, "\n");
10920         sv_catpvs(repl, "}");
10921         SvEVALED_on(repl);
10922         SvREFCNT_dec(PL_lex_repl);
10923         PL_lex_repl = repl;
10924     }
10925
10926     pm->op_pmpermflags = pm->op_pmflags;
10927     PL_lex_op = (OP*)pm;
10928     yylval.ival = OP_SUBST;
10929     return s;
10930 }
10931
10932 STATIC char *
10933 S_scan_trans(pTHX_ char *start)
10934 {
10935     dVAR;
10936     register char* s;
10937     OP *o;
10938     short *tbl;
10939     I32 squash;
10940     I32 del;
10941     I32 complement;
10942 #ifdef PERL_MAD
10943     char *modstart;
10944 #endif
10945
10946     yylval.ival = OP_NULL;
10947
10948     s = scan_str(start,!!PL_madskills,FALSE);
10949     if (!s)
10950         Perl_croak(aTHX_ "Transliteration pattern not terminated");
10951
10952     if (s[-1] == PL_multi_open)
10953         s--;
10954 #ifdef PERL_MAD
10955     if (PL_madskills) {
10956         CURMAD('q', PL_thisopen);
10957         CURMAD('_', PL_thiswhite);
10958         CURMAD('E', PL_thisstuff);
10959         CURMAD('Q', PL_thisclose);
10960         PL_realtokenstart = s - SvPVX(PL_linestr);
10961     }
10962 #endif
10963
10964     s = scan_str(s,!!PL_madskills,FALSE);
10965     if (!s) {
10966         if (PL_lex_stuff) {
10967             SvREFCNT_dec(PL_lex_stuff);
10968             PL_lex_stuff = NULL;
10969         }
10970         Perl_croak(aTHX_ "Transliteration replacement not terminated");
10971     }
10972     if (PL_madskills) {
10973         CURMAD('z', PL_thisopen);
10974         CURMAD('R', PL_thisstuff);
10975         CURMAD('Z', PL_thisclose);
10976     }
10977
10978     complement = del = squash = 0;
10979 #ifdef PERL_MAD
10980     modstart = s;
10981 #endif
10982     while (1) {
10983         switch (*s) {
10984         case 'c':
10985             complement = OPpTRANS_COMPLEMENT;
10986             break;
10987         case 'd':
10988             del = OPpTRANS_DELETE;
10989             break;
10990         case 's':
10991             squash = OPpTRANS_SQUASH;
10992             break;
10993         default:
10994             goto no_more;
10995         }
10996         s++;
10997     }
10998   no_more:
10999
11000     tbl = PerlMemShared_calloc(complement&&!del?258:256, sizeof(short));
11001     o = newPVOP(OP_TRANS, 0, (char*)tbl);
11002     o->op_private &= ~OPpTRANS_ALL;
11003     o->op_private |= del|squash|complement|
11004       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
11005       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
11006
11007     PL_lex_op = o;
11008     yylval.ival = OP_TRANS;
11009
11010 #ifdef PERL_MAD
11011     if (PL_madskills) {
11012         if (modstart != s)
11013             curmad('m', newSVpvn(modstart, s - modstart));
11014         append_madprops(PL_thismad, o, 0);
11015         PL_thismad = 0;
11016     }
11017 #endif
11018
11019     return s;
11020 }
11021
11022 STATIC char *
11023 S_scan_heredoc(pTHX_ register char *s)
11024 {
11025     dVAR;
11026     SV *herewas;
11027     I32 op_type = OP_SCALAR;
11028     I32 len;
11029     SV *tmpstr;
11030     char term;
11031     const char *found_newline;
11032     register char *d;
11033     register char *e;
11034     char *peek;
11035     const int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
11036 #ifdef PERL_MAD
11037     I32 stuffstart = s - SvPVX(PL_linestr);
11038     char *tstart;
11039
11040     PL_realtokenstart = -1;
11041 #endif
11042
11043     s += 2;
11044     d = PL_tokenbuf;
11045     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
11046     if (!outer)
11047         *d++ = '\n';
11048     peek = s;
11049     while (SPACE_OR_TAB(*peek))
11050         peek++;
11051     if (*peek == '`' || *peek == '\'' || *peek =='"') {
11052         s = peek;
11053         term = *s++;
11054         s = delimcpy(d, e, s, PL_bufend, term, &len);
11055         d += len;
11056         if (s < PL_bufend)
11057             s++;
11058     }
11059     else {
11060         if (*s == '\\')
11061             s++, term = '\'';
11062         else
11063             term = '"';
11064         if (!isALNUM_lazy_if(s,UTF))
11065             deprecate_old("bare << to mean <<\"\"");
11066         for (; isALNUM_lazy_if(s,UTF); s++) {
11067             if (d < e)
11068                 *d++ = *s;
11069         }
11070     }
11071     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
11072         Perl_croak(aTHX_ "Delimiter for here document is too long");
11073     *d++ = '\n';
11074     *d = '\0';
11075     len = d - PL_tokenbuf;
11076
11077 #ifdef PERL_MAD
11078     if (PL_madskills) {
11079         tstart = PL_tokenbuf + !outer;
11080         PL_thisclose = newSVpvn(tstart, len - !outer);
11081         tstart = SvPVX(PL_linestr) + stuffstart;
11082         PL_thisopen = newSVpvn(tstart, s - tstart);
11083         stuffstart = s - SvPVX(PL_linestr);
11084     }
11085 #endif
11086 #ifndef PERL_STRICT_CR
11087     d = strchr(s, '\r');
11088     if (d) {
11089         char * const olds = s;
11090         s = d;
11091         while (s < PL_bufend) {
11092             if (*s == '\r') {
11093                 *d++ = '\n';
11094                 if (*++s == '\n')
11095                     s++;
11096             }
11097             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
11098                 *d++ = *s++;
11099                 s++;
11100             }
11101             else
11102                 *d++ = *s++;
11103         }
11104         *d = '\0';
11105         PL_bufend = d;
11106         SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11107         s = olds;
11108     }
11109 #endif
11110 #ifdef PERL_MAD
11111     found_newline = 0;
11112 #endif
11113     if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) {
11114         herewas = newSVpvn(s,PL_bufend-s);
11115     }
11116     else {
11117 #ifdef PERL_MAD
11118         herewas = newSVpvn(s-1,found_newline-s+1);
11119 #else
11120         s--;
11121         herewas = newSVpvn(s,found_newline-s);
11122 #endif
11123     }
11124 #ifdef PERL_MAD
11125     if (PL_madskills) {
11126         tstart = SvPVX(PL_linestr) + stuffstart;
11127         if (PL_thisstuff)
11128             sv_catpvn(PL_thisstuff, tstart, s - tstart);
11129         else
11130             PL_thisstuff = newSVpvn(tstart, s - tstart);
11131     }
11132 #endif
11133     s += SvCUR(herewas);
11134
11135 #ifdef PERL_MAD
11136     stuffstart = s - SvPVX(PL_linestr);
11137
11138     if (found_newline)
11139         s--;
11140 #endif
11141
11142     tmpstr = newSV(79);
11143     sv_upgrade(tmpstr, SVt_PVIV);
11144     if (term == '\'') {
11145         op_type = OP_CONST;
11146         SvIV_set(tmpstr, -1);
11147     }
11148     else if (term == '`') {
11149         op_type = OP_BACKTICK;
11150         SvIV_set(tmpstr, '\\');
11151     }
11152
11153     CLINE;
11154     PL_multi_start = CopLINE(PL_curcop);
11155     PL_multi_open = PL_multi_close = '<';
11156     term = *PL_tokenbuf;
11157     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
11158         char * const bufptr = PL_sublex_info.super_bufptr;
11159         char * const bufend = PL_sublex_info.super_bufend;
11160         char * const olds = s - SvCUR(herewas);
11161         s = strchr(bufptr, '\n');
11162         if (!s)
11163             s = bufend;
11164         d = s;
11165         while (s < bufend &&
11166           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11167             if (*s++ == '\n')
11168                 CopLINE_inc(PL_curcop);
11169         }
11170         if (s >= bufend) {
11171             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11172             missingterm(PL_tokenbuf);
11173         }
11174         sv_setpvn(herewas,bufptr,d-bufptr+1);
11175         sv_setpvn(tmpstr,d+1,s-d);
11176         s += len - 1;
11177         sv_catpvn(herewas,s,bufend-s);
11178         Copy(SvPVX_const(herewas),bufptr,SvCUR(herewas) + 1,char);
11179
11180         s = olds;
11181         goto retval;
11182     }
11183     else if (!outer) {
11184         d = s;
11185         while (s < PL_bufend &&
11186           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
11187             if (*s++ == '\n')
11188                 CopLINE_inc(PL_curcop);
11189         }
11190         if (s >= PL_bufend) {
11191             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11192             missingterm(PL_tokenbuf);
11193         }
11194         sv_setpvn(tmpstr,d+1,s-d);
11195 #ifdef PERL_MAD
11196         if (PL_madskills) {
11197             if (PL_thisstuff)
11198                 sv_catpvn(PL_thisstuff, d + 1, s - d);
11199             else
11200                 PL_thisstuff = newSVpvn(d + 1, s - d);
11201             stuffstart = s - SvPVX(PL_linestr);
11202         }
11203 #endif
11204         s += len - 1;
11205         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
11206
11207         sv_catpvn(herewas,s,PL_bufend-s);
11208         sv_setsv(PL_linestr,herewas);
11209         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
11210         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11211         PL_last_lop = PL_last_uni = NULL;
11212     }
11213     else
11214         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
11215     while (s >= PL_bufend) {    /* multiple line string? */
11216 #ifdef PERL_MAD
11217         if (PL_madskills) {
11218             tstart = SvPVX(PL_linestr) + stuffstart;
11219             if (PL_thisstuff)
11220                 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11221             else
11222                 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11223         }
11224 #endif
11225         if (!outer ||
11226          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11227             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11228             missingterm(PL_tokenbuf);
11229         }
11230 #ifdef PERL_MAD
11231         stuffstart = s - SvPVX(PL_linestr);
11232 #endif
11233         CopLINE_inc(PL_curcop);
11234         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11235         PL_last_lop = PL_last_uni = NULL;
11236 #ifndef PERL_STRICT_CR
11237         if (PL_bufend - PL_linestart >= 2) {
11238             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
11239                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
11240             {
11241                 PL_bufend[-2] = '\n';
11242                 PL_bufend--;
11243                 SvCUR_set(PL_linestr, PL_bufend - SvPVX_const(PL_linestr));
11244             }
11245             else if (PL_bufend[-1] == '\r')
11246                 PL_bufend[-1] = '\n';
11247         }
11248         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
11249             PL_bufend[-1] = '\n';
11250 #endif
11251         if (PERLDB_LINE && PL_curstash != PL_debstash)
11252             update_debugger_info(PL_linestr, NULL, 0);
11253         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
11254             STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr);
11255             *(SvPVX(PL_linestr) + off ) = ' ';
11256             sv_catsv(PL_linestr,herewas);
11257             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11258             s = SvPVX(PL_linestr) + off; /* In case PV of PL_linestr moved. */
11259         }
11260         else {
11261             s = PL_bufend;
11262             sv_catsv(tmpstr,PL_linestr);
11263         }
11264     }
11265     s++;
11266 retval:
11267     PL_multi_end = CopLINE(PL_curcop);
11268     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
11269         SvPV_shrink_to_cur(tmpstr);
11270     }
11271     SvREFCNT_dec(herewas);
11272     if (!IN_BYTES) {
11273         if (UTF && is_utf8_string((U8*)SvPVX_const(tmpstr), SvCUR(tmpstr)))
11274             SvUTF8_on(tmpstr);
11275         else if (PL_encoding)
11276             sv_recode_to_utf8(tmpstr, PL_encoding);
11277     }
11278     PL_lex_stuff = tmpstr;
11279     yylval.ival = op_type;
11280     return s;
11281 }
11282
11283 /* scan_inputsymbol
11284    takes: current position in input buffer
11285    returns: new position in input buffer
11286    side-effects: yylval and lex_op are set.
11287
11288    This code handles:
11289
11290    <>           read from ARGV
11291    <FH>         read from filehandle
11292    <pkg::FH>    read from package qualified filehandle
11293    <pkg'FH>     read from package qualified filehandle
11294    <$fh>        read from filehandle in $fh
11295    <*.h>        filename glob
11296
11297 */
11298
11299 STATIC char *
11300 S_scan_inputsymbol(pTHX_ char *start)
11301 {
11302     dVAR;
11303     register char *s = start;           /* current position in buffer */
11304     char *end;
11305     I32 len;
11306
11307     char *d = PL_tokenbuf;                                      /* start of temp holding space */
11308     const char * const e = PL_tokenbuf + sizeof PL_tokenbuf;    /* end of temp holding space */
11309
11310     end = strchr(s, '\n');
11311     if (!end)
11312         end = PL_bufend;
11313     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
11314
11315     /* die if we didn't have space for the contents of the <>,
11316        or if it didn't end, or if we see a newline
11317     */
11318
11319     if (len >= (I32)sizeof PL_tokenbuf)
11320         Perl_croak(aTHX_ "Excessively long <> operator");
11321     if (s >= end)
11322         Perl_croak(aTHX_ "Unterminated <> operator");
11323
11324     s++;
11325
11326     /* check for <$fh>
11327        Remember, only scalar variables are interpreted as filehandles by
11328        this code.  Anything more complex (e.g., <$fh{$num}>) will be
11329        treated as a glob() call.
11330        This code makes use of the fact that except for the $ at the front,
11331        a scalar variable and a filehandle look the same.
11332     */
11333     if (*d == '$' && d[1]) d++;
11334
11335     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
11336     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
11337         d++;
11338
11339     /* If we've tried to read what we allow filehandles to look like, and
11340        there's still text left, then it must be a glob() and not a getline.
11341        Use scan_str to pull out the stuff between the <> and treat it
11342        as nothing more than a string.
11343     */
11344
11345     if (d - PL_tokenbuf != len) {
11346         yylval.ival = OP_GLOB;
11347         set_csh();
11348         s = scan_str(start,!!PL_madskills,FALSE);
11349         if (!s)
11350            Perl_croak(aTHX_ "Glob not terminated");
11351         return s;
11352     }
11353     else {
11354         bool readline_overriden = FALSE;
11355         GV *gv_readline;
11356         GV **gvp;
11357         /* we're in a filehandle read situation */
11358         d = PL_tokenbuf;
11359
11360         /* turn <> into <ARGV> */
11361         if (!len)
11362             Copy("ARGV",d,5,char);
11363
11364         /* Check whether readline() is overriden */
11365         gv_readline = gv_fetchpvs("readline", GV_NOTQUAL, SVt_PVCV);
11366         if ((gv_readline
11367                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
11368                 ||
11369                 ((gvp = (GV**)hv_fetchs(PL_globalstash, "readline", FALSE))
11370                 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
11371                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
11372             readline_overriden = TRUE;
11373
11374         /* if <$fh>, create the ops to turn the variable into a
11375            filehandle
11376         */
11377         if (*d == '$') {
11378             /* try to find it in the pad for this block, otherwise find
11379                add symbol table ops
11380             */
11381             const PADOFFSET tmp = pad_findmy(d);
11382             if (tmp != NOT_IN_PAD) {
11383                 if (PAD_COMPNAME_FLAGS_isOUR(tmp)) {
11384                     HV * const stash = PAD_COMPNAME_OURSTASH(tmp);
11385                     HEK * const stashname = HvNAME_HEK(stash);
11386                     SV * const sym = sv_2mortal(newSVhek(stashname));
11387                     sv_catpvs(sym, "::");
11388                     sv_catpv(sym, d+1);
11389                     d = SvPVX(sym);
11390                     goto intro_sym;
11391                 }
11392                 else {
11393                     OP * const o = newOP(OP_PADSV, 0);
11394                     o->op_targ = tmp;
11395                     PL_lex_op = readline_overriden
11396                         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11397                                 append_elem(OP_LIST, o,
11398                                     newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
11399                         : (OP*)newUNOP(OP_READLINE, 0, o);
11400                 }
11401             }
11402             else {
11403                 GV *gv;
11404                 ++d;
11405 intro_sym:
11406                 gv = gv_fetchpv(d,
11407                                 (PL_in_eval
11408                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
11409                                  : GV_ADDMULTI),
11410                                 SVt_PV);
11411                 PL_lex_op = readline_overriden
11412                     ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11413                             append_elem(OP_LIST,
11414                                 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
11415                                 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11416                     : (OP*)newUNOP(OP_READLINE, 0,
11417                             newUNOP(OP_RV2SV, 0,
11418                                 newGVOP(OP_GV, 0, gv)));
11419             }
11420             if (!readline_overriden)
11421                 PL_lex_op->op_flags |= OPf_SPECIAL;
11422             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
11423             yylval.ival = OP_NULL;
11424         }
11425
11426         /* If it's none of the above, it must be a literal filehandle
11427            (<Foo::BAR> or <FOO>) so build a simple readline OP */
11428         else {
11429             GV * const gv = gv_fetchpv(d, GV_ADD, SVt_PVIO);
11430             PL_lex_op = readline_overriden
11431                 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
11432                         append_elem(OP_LIST,
11433                             newGVOP(OP_GV, 0, gv),
11434                             newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
11435                 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
11436             yylval.ival = OP_NULL;
11437         }
11438     }
11439
11440     return s;
11441 }
11442
11443
11444 /* scan_str
11445    takes: start position in buffer
11446           keep_quoted preserve \ on the embedded delimiter(s)
11447           keep_delims preserve the delimiters around the string
11448    returns: position to continue reading from buffer
11449    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
11450         updates the read buffer.
11451
11452    This subroutine pulls a string out of the input.  It is called for:
11453         q               single quotes           q(literal text)
11454         '               single quotes           'literal text'
11455         qq              double quotes           qq(interpolate $here please)
11456         "               double quotes           "interpolate $here please"
11457         qx              backticks               qx(/bin/ls -l)
11458         `               backticks               `/bin/ls -l`
11459         qw              quote words             @EXPORT_OK = qw( func() $spam )
11460         m//             regexp match            m/this/
11461         s///            regexp substitute       s/this/that/
11462         tr///           string transliterate    tr/this/that/
11463         y///            string transliterate    y/this/that/
11464         ($*@)           sub prototypes          sub foo ($)
11465         (stuff)         sub attr parameters     sub foo : attr(stuff)
11466         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
11467
11468    In most of these cases (all but <>, patterns and transliterate)
11469    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
11470    calls scan_str().  s/// makes yylex() call scan_subst() which calls
11471    scan_str().  tr/// and y/// make yylex() call scan_trans() which
11472    calls scan_str().
11473
11474    It skips whitespace before the string starts, and treats the first
11475    character as the delimiter.  If the delimiter is one of ([{< then
11476    the corresponding "close" character )]}> is used as the closing
11477    delimiter.  It allows quoting of delimiters, and if the string has
11478    balanced delimiters ([{<>}]) it allows nesting.
11479
11480    On success, the SV with the resulting string is put into lex_stuff or,
11481    if that is already non-NULL, into lex_repl. The second case occurs only
11482    when parsing the RHS of the special constructs s/// and tr/// (y///).
11483    For convenience, the terminating delimiter character is stuffed into
11484    SvIVX of the SV.
11485 */
11486
11487 STATIC char *
11488 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
11489 {
11490     dVAR;
11491     SV *sv;                             /* scalar value: string */
11492     const char *tmps;                   /* temp string, used for delimiter matching */
11493     register char *s = start;           /* current position in the buffer */
11494     register char term;                 /* terminating character */
11495     register char *to;                  /* current position in the sv's data */
11496     I32 brackets = 1;                   /* bracket nesting level */
11497     bool has_utf8 = FALSE;              /* is there any utf8 content? */
11498     I32 termcode;                       /* terminating char. code */
11499     U8 termstr[UTF8_MAXBYTES];          /* terminating string */
11500     STRLEN termlen;                     /* length of terminating string */
11501     int last_off = 0;                   /* last position for nesting bracket */
11502 #ifdef PERL_MAD
11503     int stuffstart;
11504     char *tstart;
11505 #endif
11506
11507     /* skip space before the delimiter */
11508     if (isSPACE(*s)) {
11509         s = PEEKSPACE(s);
11510     }
11511
11512 #ifdef PERL_MAD
11513     if (PL_realtokenstart >= 0) {
11514         stuffstart = PL_realtokenstart;
11515         PL_realtokenstart = -1;
11516     }
11517     else
11518         stuffstart = start - SvPVX(PL_linestr);
11519 #endif
11520     /* mark where we are, in case we need to report errors */
11521     CLINE;
11522
11523     /* after skipping whitespace, the next character is the terminator */
11524     term = *s;
11525     if (!UTF) {
11526         termcode = termstr[0] = term;
11527         termlen = 1;
11528     }
11529     else {
11530         termcode = utf8_to_uvchr((U8*)s, &termlen);
11531         Copy(s, termstr, termlen, U8);
11532         if (!UTF8_IS_INVARIANT(term))
11533             has_utf8 = TRUE;
11534     }
11535
11536     /* mark where we are */
11537     PL_multi_start = CopLINE(PL_curcop);
11538     PL_multi_open = term;
11539
11540     /* find corresponding closing delimiter */
11541     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
11542         termcode = termstr[0] = term = tmps[5];
11543
11544     PL_multi_close = term;
11545
11546     /* create a new SV to hold the contents.  79 is the SV's initial length.
11547        What a random number. */
11548     sv = newSV(79);
11549     sv_upgrade(sv, SVt_PVIV);
11550     SvIV_set(sv, termcode);
11551     (void)SvPOK_only(sv);               /* validate pointer */
11552
11553     /* move past delimiter and try to read a complete string */
11554     if (keep_delims)
11555         sv_catpvn(sv, s, termlen);
11556     s += termlen;
11557 #ifdef PERL_MAD
11558     tstart = SvPVX(PL_linestr) + stuffstart;
11559     if (!PL_thisopen && !keep_delims) {
11560         PL_thisopen = newSVpvn(tstart, s - tstart);
11561         stuffstart = s - SvPVX(PL_linestr);
11562     }
11563 #endif
11564     for (;;) {
11565         if (PL_encoding && !UTF) {
11566             bool cont = TRUE;
11567
11568             while (cont) {
11569                 int offset = s - SvPVX_const(PL_linestr);
11570                 const bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
11571                                            &offset, (char*)termstr, termlen);
11572                 const char * const ns = SvPVX_const(PL_linestr) + offset;
11573                 char * const svlast = SvEND(sv) - 1;
11574
11575                 for (; s < ns; s++) {
11576                     if (*s == '\n' && !PL_rsfp)
11577                         CopLINE_inc(PL_curcop);
11578                 }
11579                 if (!found)
11580                     goto read_more_line;
11581                 else {
11582                     /* handle quoted delimiters */
11583                     if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
11584                         const char *t;
11585                         for (t = svlast-2; t >= SvPVX_const(sv) && *t == '\\';)
11586                             t--;
11587                         if ((svlast-1 - t) % 2) {
11588                             if (!keep_quoted) {
11589                                 *(svlast-1) = term;
11590                                 *svlast = '\0';
11591                                 SvCUR_set(sv, SvCUR(sv) - 1);
11592                             }
11593                             continue;
11594                         }
11595                     }
11596                     if (PL_multi_open == PL_multi_close) {
11597                         cont = FALSE;
11598                     }
11599                     else {
11600                         const char *t;
11601                         char *w;
11602                         for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) {
11603                             /* At here, all closes are "was quoted" one,
11604                                so we don't check PL_multi_close. */
11605                             if (*t == '\\') {
11606                                 if (!keep_quoted && *(t+1) == PL_multi_open)
11607                                     t++;
11608                                 else
11609                                     *w++ = *t++;
11610                             }
11611                             else if (*t == PL_multi_open)
11612                                 brackets++;
11613
11614                             *w = *t;
11615                         }
11616                         if (w < t) {
11617                             *w++ = term;
11618                             *w = '\0';
11619                             SvCUR_set(sv, w - SvPVX_const(sv));
11620                         }
11621                         last_off = w - SvPVX(sv);
11622                         if (--brackets <= 0)
11623                             cont = FALSE;
11624                     }
11625                 }
11626             }
11627             if (!keep_delims) {
11628                 SvCUR_set(sv, SvCUR(sv) - 1);
11629                 *SvEND(sv) = '\0';
11630             }
11631             break;
11632         }
11633
11634         /* extend sv if need be */
11635         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
11636         /* set 'to' to the next character in the sv's string */
11637         to = SvPVX(sv)+SvCUR(sv);
11638
11639         /* if open delimiter is the close delimiter read unbridle */
11640         if (PL_multi_open == PL_multi_close) {
11641             for (; s < PL_bufend; s++,to++) {
11642                 /* embedded newlines increment the current line number */
11643                 if (*s == '\n' && !PL_rsfp)
11644                     CopLINE_inc(PL_curcop);
11645                 /* handle quoted delimiters */
11646                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
11647                     if (!keep_quoted && s[1] == term)
11648                         s++;
11649                 /* any other quotes are simply copied straight through */
11650                     else
11651                         *to++ = *s++;
11652                 }
11653                 /* terminate when run out of buffer (the for() condition), or
11654                    have found the terminator */
11655                 else if (*s == term) {
11656                     if (termlen == 1)
11657                         break;
11658                     if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
11659                         break;
11660                 }
11661                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11662                     has_utf8 = TRUE;
11663                 *to = *s;
11664             }
11665         }
11666
11667         /* if the terminator isn't the same as the start character (e.g.,
11668            matched brackets), we have to allow more in the quoting, and
11669            be prepared for nested brackets.
11670         */
11671         else {
11672             /* read until we run out of string, or we find the terminator */
11673             for (; s < PL_bufend; s++,to++) {
11674                 /* embedded newlines increment the line count */
11675                 if (*s == '\n' && !PL_rsfp)
11676                     CopLINE_inc(PL_curcop);
11677                 /* backslashes can escape the open or closing characters */
11678                 if (*s == '\\' && s+1 < PL_bufend) {
11679                     if (!keep_quoted &&
11680                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
11681                         s++;
11682                     else
11683                         *to++ = *s++;
11684                 }
11685                 /* allow nested opens and closes */
11686                 else if (*s == PL_multi_close && --brackets <= 0)
11687                     break;
11688                 else if (*s == PL_multi_open)
11689                     brackets++;
11690                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
11691                     has_utf8 = TRUE;
11692                 *to = *s;
11693             }
11694         }
11695         /* terminate the copied string and update the sv's end-of-string */
11696         *to = '\0';
11697         SvCUR_set(sv, to - SvPVX_const(sv));
11698
11699         /*
11700          * this next chunk reads more into the buffer if we're not done yet
11701          */
11702
11703         if (s < PL_bufend)
11704             break;              /* handle case where we are done yet :-) */
11705
11706 #ifndef PERL_STRICT_CR
11707         if (to - SvPVX_const(sv) >= 2) {
11708             if ((to[-2] == '\r' && to[-1] == '\n') ||
11709                 (to[-2] == '\n' && to[-1] == '\r'))
11710             {
11711                 to[-2] = '\n';
11712                 to--;
11713                 SvCUR_set(sv, to - SvPVX_const(sv));
11714             }
11715             else if (to[-1] == '\r')
11716                 to[-1] = '\n';
11717         }
11718         else if (to - SvPVX_const(sv) == 1 && to[-1] == '\r')
11719             to[-1] = '\n';
11720 #endif
11721
11722      read_more_line:
11723         /* if we're out of file, or a read fails, bail and reset the current
11724            line marker so we can report where the unterminated string began
11725         */
11726 #ifdef PERL_MAD
11727         if (PL_madskills) {
11728             char * const tstart = SvPVX(PL_linestr) + stuffstart;
11729             if (PL_thisstuff)
11730                 sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart);
11731             else
11732                 PL_thisstuff = newSVpvn(tstart, PL_bufend - tstart);
11733         }
11734 #endif
11735         if (!PL_rsfp ||
11736          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
11737             sv_free(sv);
11738             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
11739             return NULL;
11740         }
11741 #ifdef PERL_MAD
11742         stuffstart = 0;
11743 #endif
11744         /* we read a line, so increment our line counter */
11745         CopLINE_inc(PL_curcop);
11746
11747         /* update debugger info */
11748         if (PERLDB_LINE && PL_curstash != PL_debstash)
11749             update_debugger_info(PL_linestr, NULL, 0);
11750
11751         /* having changed the buffer, we must update PL_bufend */
11752         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
11753         PL_last_lop = PL_last_uni = NULL;
11754     }
11755
11756     /* at this point, we have successfully read the delimited string */
11757
11758     if (!PL_encoding || UTF) {
11759 #ifdef PERL_MAD
11760         if (PL_madskills) {
11761             char * const tstart = SvPVX(PL_linestr) + stuffstart;
11762             const int len = s - tstart;
11763             if (PL_thisstuff)
11764                 sv_catpvn(PL_thisstuff, tstart, len);
11765             else
11766                 PL_thisstuff = newSVpvn(tstart, len);
11767             if (!PL_thisclose && !keep_delims)
11768                 PL_thisclose = newSVpvn(s,termlen);
11769         }
11770 #endif
11771
11772         if (keep_delims)
11773             sv_catpvn(sv, s, termlen);
11774         s += termlen;
11775     }
11776 #ifdef PERL_MAD
11777     else {
11778         if (PL_madskills) {
11779             char * const tstart = SvPVX(PL_linestr) + stuffstart;
11780             const int len = s - tstart - termlen;
11781             if (PL_thisstuff)
11782                 sv_catpvn(PL_thisstuff, tstart, len);
11783             else
11784                 PL_thisstuff = newSVpvn(tstart, len);
11785             if (!PL_thisclose && !keep_delims)
11786                 PL_thisclose = newSVpvn(s - termlen,termlen);
11787         }
11788     }
11789 #endif
11790     if (has_utf8 || PL_encoding)
11791         SvUTF8_on(sv);
11792
11793     PL_multi_end = CopLINE(PL_curcop);
11794
11795     /* if we allocated too much space, give some back */
11796     if (SvCUR(sv) + 5 < SvLEN(sv)) {
11797         SvLEN_set(sv, SvCUR(sv) + 1);
11798         SvPV_renew(sv, SvLEN(sv));
11799     }
11800
11801     /* decide whether this is the first or second quoted string we've read
11802        for this op
11803     */
11804
11805     if (PL_lex_stuff)
11806         PL_lex_repl = sv;
11807     else
11808         PL_lex_stuff = sv;
11809     return s;
11810 }
11811
11812 /*
11813   scan_num
11814   takes: pointer to position in buffer
11815   returns: pointer to new position in buffer
11816   side-effects: builds ops for the constant in yylval.op
11817
11818   Read a number in any of the formats that Perl accepts:
11819
11820   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
11821   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
11822   0b[01](_?[01])*
11823   0[0-7](_?[0-7])*
11824   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
11825
11826   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
11827   thing it reads.
11828
11829   If it reads a number without a decimal point or an exponent, it will
11830   try converting the number to an integer and see if it can do so
11831   without loss of precision.
11832 */
11833
11834 char *
11835 Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
11836 {
11837     dVAR;
11838     register const char *s = start;     /* current position in buffer */
11839     register char *d;                   /* destination in temp buffer */
11840     register char *e;                   /* end of temp buffer */
11841     NV nv;                              /* number read, as a double */
11842     SV *sv = NULL;                      /* place to put the converted number */
11843     bool floatit;                       /* boolean: int or float? */
11844     const char *lastub = NULL;          /* position of last underbar */
11845     static char const number_too_long[] = "Number too long";
11846
11847     /* We use the first character to decide what type of number this is */
11848
11849     switch (*s) {
11850     default:
11851       Perl_croak(aTHX_ "panic: scan_num");
11852
11853     /* if it starts with a 0, it could be an octal number, a decimal in
11854        0.13 disguise, or a hexadecimal number, or a binary number. */
11855     case '0':
11856         {
11857           /* variables:
11858              u          holds the "number so far"
11859              shift      the power of 2 of the base
11860                         (hex == 4, octal == 3, binary == 1)
11861              overflowed was the number more than we can hold?
11862
11863              Shift is used when we add a digit.  It also serves as an "are
11864              we in octal/hex/binary?" indicator to disallow hex characters
11865              when in octal mode.
11866            */
11867             NV n = 0.0;
11868             UV u = 0;
11869             I32 shift;
11870             bool overflowed = FALSE;
11871             bool just_zero  = TRUE;     /* just plain 0 or binary number? */
11872             static const NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
11873             static const char* const bases[5] =
11874               { "", "binary", "", "octal", "hexadecimal" };
11875             static const char* const Bases[5] =
11876               { "", "Binary", "", "Octal", "Hexadecimal" };
11877             static const char* const maxima[5] =
11878               { "",
11879                 "0b11111111111111111111111111111111",
11880                 "",
11881                 "037777777777",
11882                 "0xffffffff" };
11883             const char *base, *Base, *max;
11884
11885             /* check for hex */
11886             if (s[1] == 'x') {
11887                 shift = 4;
11888                 s += 2;
11889                 just_zero = FALSE;
11890             } else if (s[1] == 'b') {
11891                 shift = 1;
11892                 s += 2;
11893                 just_zero = FALSE;
11894             }
11895             /* check for a decimal in disguise */
11896             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
11897                 goto decimal;
11898             /* so it must be octal */
11899             else {
11900                 shift = 3;
11901                 s++;
11902             }
11903
11904             if (*s == '_') {
11905                if (ckWARN(WARN_SYNTAX))
11906                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11907                                "Misplaced _ in number");
11908                lastub = s++;
11909             }
11910
11911             base = bases[shift];
11912             Base = Bases[shift];
11913             max  = maxima[shift];
11914
11915             /* read the rest of the number */
11916             for (;;) {
11917                 /* x is used in the overflow test,
11918                    b is the digit we're adding on. */
11919                 UV x, b;
11920
11921                 switch (*s) {
11922
11923                 /* if we don't mention it, we're done */
11924                 default:
11925                     goto out;
11926
11927                 /* _ are ignored -- but warned about if consecutive */
11928                 case '_':
11929                     if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
11930                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
11931                                     "Misplaced _ in number");
11932                     lastub = s++;
11933                     break;
11934
11935                 /* 8 and 9 are not octal */
11936                 case '8': case '9':
11937                     if (shift == 3)
11938                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
11939                     /* FALL THROUGH */
11940
11941                 /* octal digits */
11942                 case '2': case '3': case '4':
11943                 case '5': case '6': case '7':
11944                     if (shift == 1)
11945                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
11946                     /* FALL THROUGH */
11947
11948                 case '0': case '1':
11949                     b = *s++ & 15;              /* ASCII digit -> value of digit */
11950                     goto digit;
11951
11952                 /* hex digits */
11953                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
11954                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
11955                     /* make sure they said 0x */
11956                     if (shift != 4)
11957                         goto out;
11958                     b = (*s++ & 7) + 9;
11959
11960                     /* Prepare to put the digit we have onto the end
11961                        of the number so far.  We check for overflows.
11962                     */
11963
11964                   digit:
11965                     just_zero = FALSE;
11966                     if (!overflowed) {
11967                         x = u << shift; /* make room for the digit */
11968
11969                         if ((x >> shift) != u
11970                             && !(PL_hints & HINT_NEW_BINARY)) {
11971                             overflowed = TRUE;
11972                             n = (NV) u;
11973                             if (ckWARN_d(WARN_OVERFLOW))
11974                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
11975                                             "Integer overflow in %s number",
11976                                             base);
11977                         } else
11978                             u = x | b;          /* add the digit to the end */
11979                     }
11980                     if (overflowed) {
11981                         n *= nvshift[shift];
11982                         /* If an NV has not enough bits in its
11983                          * mantissa to represent an UV this summing of
11984                          * small low-order numbers is a waste of time
11985                          * (because the NV cannot preserve the
11986                          * low-order bits anyway): we could just
11987                          * remember when did we overflow and in the
11988                          * end just multiply n by the right
11989                          * amount. */
11990                         n += (NV) b;
11991                     }
11992                     break;
11993                 }
11994             }
11995
11996           /* if we get here, we had success: make a scalar value from
11997              the number.
11998           */
11999           out:
12000
12001             /* final misplaced underbar check */
12002             if (s[-1] == '_') {
12003                 if (ckWARN(WARN_SYNTAX))
12004                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12005             }
12006
12007             sv = newSV(0);
12008             if (overflowed) {
12009                 if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
12010                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12011                                 "%s number > %s non-portable",
12012                                 Base, max);
12013                 sv_setnv(sv, n);
12014             }
12015             else {
12016 #if UVSIZE > 4
12017                 if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
12018                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
12019                                 "%s number > %s non-portable",
12020                                 Base, max);
12021 #endif
12022                 sv_setuv(sv, u);
12023             }
12024             if (just_zero && (PL_hints & HINT_NEW_INTEGER))
12025                 sv = new_constant(start, s - start, "integer",
12026                                   sv, NULL, NULL);
12027             else if (PL_hints & HINT_NEW_BINARY)
12028                 sv = new_constant(start, s - start, "binary", sv, NULL, NULL);
12029         }
12030         break;
12031
12032     /*
12033       handle decimal numbers.
12034       we're also sent here when we read a 0 as the first digit
12035     */
12036     case '1': case '2': case '3': case '4': case '5':
12037     case '6': case '7': case '8': case '9': case '.':
12038       decimal:
12039         d = PL_tokenbuf;
12040         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
12041         floatit = FALSE;
12042
12043         /* read next group of digits and _ and copy into d */
12044         while (isDIGIT(*s) || *s == '_') {
12045             /* skip underscores, checking for misplaced ones
12046                if -w is on
12047             */
12048             if (*s == '_') {
12049                 if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12050                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12051                                 "Misplaced _ in number");
12052                 lastub = s++;
12053             }
12054             else {
12055                 /* check for end of fixed-length buffer */
12056                 if (d >= e)
12057                     Perl_croak(aTHX_ number_too_long);
12058                 /* if we're ok, copy the character */
12059                 *d++ = *s++;
12060             }
12061         }
12062
12063         /* final misplaced underbar check */
12064         if (lastub && s == lastub + 1) {
12065             if (ckWARN(WARN_SYNTAX))
12066                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
12067         }
12068
12069         /* read a decimal portion if there is one.  avoid
12070            3..5 being interpreted as the number 3. followed
12071            by .5
12072         */
12073         if (*s == '.' && s[1] != '.') {
12074             floatit = TRUE;
12075             *d++ = *s++;
12076
12077             if (*s == '_') {
12078                 if (ckWARN(WARN_SYNTAX))
12079                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12080                                 "Misplaced _ in number");
12081                 lastub = s;
12082             }
12083
12084             /* copy, ignoring underbars, until we run out of digits.
12085             */
12086             for (; isDIGIT(*s) || *s == '_'; s++) {
12087                 /* fixed length buffer check */
12088                 if (d >= e)
12089                     Perl_croak(aTHX_ number_too_long);
12090                 if (*s == '_') {
12091                    if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
12092                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12093                                    "Misplaced _ in number");
12094                    lastub = s;
12095                 }
12096                 else
12097                     *d++ = *s;
12098             }
12099             /* fractional part ending in underbar? */
12100             if (s[-1] == '_') {
12101                 if (ckWARN(WARN_SYNTAX))
12102                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12103                                 "Misplaced _ in number");
12104             }
12105             if (*s == '.' && isDIGIT(s[1])) {
12106                 /* oops, it's really a v-string, but without the "v" */
12107                 s = start;
12108                 goto vstring;
12109             }
12110         }
12111
12112         /* read exponent part, if present */
12113         if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) {
12114             floatit = TRUE;
12115             s++;
12116
12117             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
12118             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
12119
12120             /* stray preinitial _ */
12121             if (*s == '_') {
12122                 if (ckWARN(WARN_SYNTAX))
12123                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12124                                 "Misplaced _ in number");
12125                 lastub = s++;
12126             }
12127
12128             /* allow positive or negative exponent */
12129             if (*s == '+' || *s == '-')
12130                 *d++ = *s++;
12131
12132             /* stray initial _ */
12133             if (*s == '_') {
12134                 if (ckWARN(WARN_SYNTAX))
12135                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12136                                 "Misplaced _ in number");
12137                 lastub = s++;
12138             }
12139
12140             /* read digits of exponent */
12141             while (isDIGIT(*s) || *s == '_') {
12142                 if (isDIGIT(*s)) {
12143                     if (d >= e)
12144                         Perl_croak(aTHX_ number_too_long);
12145                     *d++ = *s++;
12146                 }
12147                 else {
12148                    if (((lastub && s == lastub + 1) ||
12149                         (!isDIGIT(s[1]) && s[1] != '_'))
12150                     && ckWARN(WARN_SYNTAX))
12151                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
12152                                    "Misplaced _ in number");
12153                    lastub = s++;
12154                 }
12155             }
12156         }
12157
12158
12159         /* make an sv from the string */
12160         sv = newSV(0);
12161
12162         /*
12163            We try to do an integer conversion first if no characters
12164            indicating "float" have been found.
12165          */
12166
12167         if (!floatit) {
12168             UV uv;
12169             const int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
12170
12171             if (flags == IS_NUMBER_IN_UV) {
12172               if (uv <= IV_MAX)
12173                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
12174               else
12175                 sv_setuv(sv, uv);
12176             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
12177               if (uv <= (UV) IV_MIN)
12178                 sv_setiv(sv, -(IV)uv);
12179               else
12180                 floatit = TRUE;
12181             } else
12182               floatit = TRUE;
12183         }
12184         if (floatit) {
12185             /* terminate the string */
12186             *d = '\0';
12187             nv = Atof(PL_tokenbuf);
12188             sv_setnv(sv, nv);
12189         }
12190
12191         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
12192                        (PL_hints & HINT_NEW_INTEGER) )
12193             sv = new_constant(PL_tokenbuf,
12194                               d - PL_tokenbuf,
12195                               (const char *)
12196                               (floatit ? "float" : "integer"),
12197                               sv, NULL, NULL);
12198         break;
12199
12200     /* if it starts with a v, it could be a v-string */
12201     case 'v':
12202 vstring:
12203                 sv = newSV(5); /* preallocate storage space */
12204                 s = scan_vstring(s,sv);
12205         break;
12206     }
12207
12208     /* make the op for the constant and return */
12209
12210     if (sv)
12211         lvalp->opval = newSVOP(OP_CONST, 0, sv);
12212     else
12213         lvalp->opval = NULL;
12214
12215     return (char *)s;
12216 }
12217
12218 STATIC char *
12219 S_scan_formline(pTHX_ register char *s)
12220 {
12221     dVAR;
12222     register char *eol;
12223     register char *t;
12224     SV * const stuff = newSVpvs("");
12225     bool needargs = FALSE;
12226     bool eofmt = FALSE;
12227 #ifdef PERL_MAD
12228     char *tokenstart = s;
12229     SV* savewhite;
12230
12231     if (PL_madskills) {
12232         savewhite = PL_thiswhite;
12233         PL_thiswhite = 0;
12234     }
12235 #endif
12236
12237     while (!needargs) {
12238         if (*s == '.') {
12239             t = s+1;
12240 #ifdef PERL_STRICT_CR
12241             while (SPACE_OR_TAB(*t))
12242                 t++;
12243 #else
12244             while (SPACE_OR_TAB(*t) || *t == '\r')
12245                 t++;
12246 #endif
12247             if (*t == '\n' || t == PL_bufend) {
12248                 eofmt = TRUE;
12249                 break;
12250             }
12251         }
12252         if (PL_in_eval && !PL_rsfp) {
12253             eol = (char *) memchr(s,'\n',PL_bufend-s);
12254             if (!eol++)
12255                 eol = PL_bufend;
12256         }
12257         else
12258             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
12259         if (*s != '#') {
12260             for (t = s; t < eol; t++) {
12261                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
12262                     needargs = FALSE;
12263                     goto enough;        /* ~~ must be first line in formline */
12264                 }
12265                 if (*t == '@' || *t == '^')
12266                     needargs = TRUE;
12267             }
12268             if (eol > s) {
12269                 sv_catpvn(stuff, s, eol-s);
12270 #ifndef PERL_STRICT_CR
12271                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
12272                     char *end = SvPVX(stuff) + SvCUR(stuff);
12273                     end[-2] = '\n';
12274                     end[-1] = '\0';
12275                     SvCUR_set(stuff, SvCUR(stuff) - 1);
12276                 }
12277 #endif
12278             }
12279             else
12280               break;
12281         }
12282         s = (char*)eol;
12283         if (PL_rsfp) {
12284 #ifdef PERL_MAD
12285             if (PL_madskills) {
12286                 if (PL_thistoken)
12287                     sv_catpvn(PL_thistoken, tokenstart, PL_bufend - tokenstart);
12288                 else
12289                     PL_thistoken = newSVpvn(tokenstart, PL_bufend - tokenstart);
12290             }
12291 #endif
12292             s = filter_gets(PL_linestr, PL_rsfp, 0);
12293 #ifdef PERL_MAD
12294             tokenstart = PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12295 #else
12296             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
12297 #endif
12298             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
12299             PL_last_lop = PL_last_uni = NULL;
12300             if (!s) {
12301                 s = PL_bufptr;
12302                 break;
12303             }
12304         }
12305         incline(s);
12306     }
12307   enough:
12308     if (SvCUR(stuff)) {
12309         PL_expect = XTERM;
12310         if (needargs) {
12311             PL_lex_state = LEX_NORMAL;
12312             start_force(PL_curforce);
12313             NEXTVAL_NEXTTOKE.ival = 0;
12314             force_next(',');
12315         }
12316         else
12317             PL_lex_state = LEX_FORMLINE;
12318         if (!IN_BYTES) {
12319             if (UTF && is_utf8_string((U8*)SvPVX_const(stuff), SvCUR(stuff)))
12320                 SvUTF8_on(stuff);
12321             else if (PL_encoding)
12322                 sv_recode_to_utf8(stuff, PL_encoding);
12323         }
12324         start_force(PL_curforce);
12325         NEXTVAL_NEXTTOKE.opval = (OP*)newSVOP(OP_CONST, 0, stuff);
12326         force_next(THING);
12327         start_force(PL_curforce);
12328         NEXTVAL_NEXTTOKE.ival = OP_FORMLINE;
12329         force_next(LSTOP);
12330     }
12331     else {
12332         SvREFCNT_dec(stuff);
12333         if (eofmt)
12334             PL_lex_formbrack = 0;
12335         PL_bufptr = s;
12336     }
12337 #ifdef PERL_MAD
12338     if (PL_madskills) {
12339         if (PL_thistoken)
12340             sv_catpvn(PL_thistoken, tokenstart, s - tokenstart);
12341         else
12342             PL_thistoken = newSVpvn(tokenstart, s - tokenstart);
12343         PL_thiswhite = savewhite;
12344     }
12345 #endif
12346     return s;
12347 }
12348
12349 STATIC void
12350 S_set_csh(pTHX)
12351 {
12352 #ifdef CSH
12353     dVAR;
12354     if (!PL_cshlen)
12355         PL_cshlen = strlen(PL_cshname);
12356 #else
12357 #if defined(USE_ITHREADS)
12358     PERL_UNUSED_CONTEXT;
12359 #endif
12360 #endif
12361 }
12362
12363 I32
12364 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
12365 {
12366     dVAR;
12367     const I32 oldsavestack_ix = PL_savestack_ix;
12368     CV* const outsidecv = PL_compcv;
12369
12370     if (PL_compcv) {
12371         assert(SvTYPE(PL_compcv) == SVt_PVCV);
12372     }
12373     SAVEI32(PL_subline);
12374     save_item(PL_subname);
12375     SAVESPTR(PL_compcv);
12376
12377     PL_compcv = (CV*)newSV(0);
12378     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
12379     CvFLAGS(PL_compcv) |= flags;
12380
12381     PL_subline = CopLINE(PL_curcop);
12382     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
12383     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outsidecv);
12384     CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
12385
12386     return oldsavestack_ix;
12387 }
12388
12389 #ifdef __SC__
12390 #pragma segment Perl_yylex
12391 #endif
12392 int
12393 Perl_yywarn(pTHX_ const char *s)
12394 {
12395     dVAR;
12396     PL_in_eval |= EVAL_WARNONLY;
12397     yyerror(s);
12398     PL_in_eval &= ~EVAL_WARNONLY;
12399     return 0;
12400 }
12401
12402 int
12403 Perl_yyerror(pTHX_ const char *s)
12404 {
12405     dVAR;
12406     const char *where = NULL;
12407     const char *context = NULL;
12408     int contlen = -1;
12409     SV *msg;
12410     int yychar  = PL_parser->yychar;
12411
12412     if (!yychar || (yychar == ';' && !PL_rsfp))
12413         where = "at EOF";
12414     else if (PL_oldoldbufptr && PL_bufptr > PL_oldoldbufptr &&
12415       PL_bufptr - PL_oldoldbufptr < 200 && PL_oldoldbufptr != PL_oldbufptr &&
12416       PL_oldbufptr != PL_bufptr) {
12417         /*
12418                 Only for NetWare:
12419                 The code below is removed for NetWare because it abends/crashes on NetWare
12420                 when the script has error such as not having the closing quotes like:
12421                     if ($var eq "value)
12422                 Checking of white spaces is anyway done in NetWare code.
12423         */
12424 #ifndef NETWARE
12425         while (isSPACE(*PL_oldoldbufptr))
12426             PL_oldoldbufptr++;
12427 #endif
12428         context = PL_oldoldbufptr;
12429         contlen = PL_bufptr - PL_oldoldbufptr;
12430     }
12431     else if (PL_oldbufptr && PL_bufptr > PL_oldbufptr &&
12432       PL_bufptr - PL_oldbufptr < 200 && PL_oldbufptr != PL_bufptr) {
12433         /*
12434                 Only for NetWare:
12435                 The code below is removed for NetWare because it abends/crashes on NetWare
12436                 when the script has error such as not having the closing quotes like:
12437                     if ($var eq "value)
12438                 Checking of white spaces is anyway done in NetWare code.
12439         */
12440 #ifndef NETWARE
12441         while (isSPACE(*PL_oldbufptr))
12442             PL_oldbufptr++;
12443 #endif
12444         context = PL_oldbufptr;
12445         contlen = PL_bufptr - PL_oldbufptr;
12446     }
12447     else if (yychar > 255)
12448         where = "next token ???";
12449     else if (yychar == -2) { /* YYEMPTY */
12450         if (PL_lex_state == LEX_NORMAL ||
12451            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
12452             where = "at end of line";
12453         else if (PL_lex_inpat)
12454             where = "within pattern";
12455         else
12456             where = "within string";
12457     }
12458     else {
12459         SV * const where_sv = sv_2mortal(newSVpvs("next char "));
12460         if (yychar < 32)
12461             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
12462         else if (isPRINT_LC(yychar))
12463             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
12464         else
12465             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
12466         where = SvPVX_const(where_sv);
12467     }
12468     msg = sv_2mortal(newSVpv(s, 0));
12469     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
12470         OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
12471     if (context)
12472         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
12473     else
12474         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
12475     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
12476         Perl_sv_catpvf(aTHX_ msg,
12477         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
12478                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
12479         PL_multi_end = 0;
12480     }
12481     if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
12482         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg));
12483     else
12484         qerror(msg);
12485     if (PL_error_count >= 10) {
12486         if (PL_in_eval && SvCUR(ERRSV))
12487             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
12488                        SVfARG(ERRSV), OutCopFILE(PL_curcop));
12489         else
12490             Perl_croak(aTHX_ "%s has too many errors.\n",
12491             OutCopFILE(PL_curcop));
12492     }
12493     PL_in_my = 0;
12494     PL_in_my_stash = NULL;
12495     return 0;
12496 }
12497 #ifdef __SC__
12498 #pragma segment Main
12499 #endif
12500
12501 STATIC char*
12502 S_swallow_bom(pTHX_ U8 *s)
12503 {
12504     dVAR;
12505     const STRLEN slen = SvCUR(PL_linestr);
12506     switch (s[0]) {
12507     case 0xFF:
12508         if (s[1] == 0xFE) {
12509             /* UTF-16 little-endian? (or UTF32-LE?) */
12510             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
12511                 Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE");
12512 #ifndef PERL_NO_UTF16_FILTER
12513             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n");
12514             s += 2;
12515         utf16le:
12516             if (PL_bufend > (char*)s) {
12517                 U8 *news;
12518                 I32 newlen;
12519
12520                 filter_add(utf16rev_textfilter, NULL);
12521                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12522                 utf16_to_utf8_reversed(s, news,
12523                                        PL_bufend - (char*)s - 1,
12524                                        &newlen);
12525                 sv_setpvn(PL_linestr, (const char*)news, newlen);
12526 #ifdef PERL_MAD
12527                 s = (U8*)SvPVX(PL_linestr);
12528                 Copy(news, s, newlen, U8);
12529                 s[newlen] = '\0';
12530 #endif
12531                 Safefree(news);
12532                 SvUTF8_on(PL_linestr);
12533                 s = (U8*)SvPVX(PL_linestr);
12534 #ifdef PERL_MAD
12535                 /* FIXME - is this a general bug fix?  */
12536                 s[newlen] = '\0';
12537 #endif
12538                 PL_bufend = SvPVX(PL_linestr) + newlen;
12539             }
12540 #else
12541             Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE");
12542 #endif
12543         }
12544         break;
12545     case 0xFE:
12546         if (s[1] == 0xFF) {   /* UTF-16 big-endian? */
12547 #ifndef PERL_NO_UTF16_FILTER
12548             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n");
12549             s += 2;
12550         utf16be:
12551             if (PL_bufend > (char *)s) {
12552                 U8 *news;
12553                 I32 newlen;
12554
12555                 filter_add(utf16_textfilter, NULL);
12556                 Newx(news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
12557                 utf16_to_utf8(s, news,
12558                               PL_bufend - (char*)s,
12559                               &newlen);
12560                 sv_setpvn(PL_linestr, (const char*)news, newlen);
12561                 Safefree(news);
12562                 SvUTF8_on(PL_linestr);
12563                 s = (U8*)SvPVX(PL_linestr);
12564                 PL_bufend = SvPVX(PL_linestr) + newlen;
12565             }
12566 #else
12567             Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE");
12568 #endif
12569         }
12570         break;
12571     case 0xEF:
12572         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
12573             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12574             s += 3;                      /* UTF-8 */
12575         }
12576         break;
12577     case 0:
12578         if (slen > 3) {
12579              if (s[1] == 0) {
12580                   if (s[2] == 0xFE && s[3] == 0xFF) {
12581                        /* UTF-32 big-endian */
12582                        Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE");
12583                   }
12584              }
12585              else if (s[2] == 0 && s[3] != 0) {
12586                   /* Leading bytes
12587                    * 00 xx 00 xx
12588                    * are a good indicator of UTF-16BE. */
12589                   if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n");
12590                   goto utf16be;
12591              }
12592         }
12593 #ifdef EBCDIC
12594     case 0xDD:
12595         if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) {
12596             if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n");
12597             s += 4;                      /* UTF-8 */
12598         }
12599         break;
12600 #endif
12601
12602     default:
12603          if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) {
12604                   /* Leading bytes
12605                    * xx 00 xx 00
12606                    * are a good indicator of UTF-16LE. */
12607               if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n");
12608               goto utf16le;
12609          }
12610     }
12611     return (char*)s;
12612 }
12613
12614 /*
12615  * restore_rsfp
12616  * Restore a source filter.
12617  */
12618
12619 static void
12620 restore_rsfp(pTHX_ void *f)
12621 {
12622     dVAR;
12623     PerlIO * const fp = (PerlIO*)f;
12624
12625     if (PL_rsfp == PerlIO_stdin())
12626         PerlIO_clearerr(PL_rsfp);
12627     else if (PL_rsfp && (PL_rsfp != fp))
12628         PerlIO_close(PL_rsfp);
12629     PL_rsfp = fp;
12630 }
12631
12632 #ifndef PERL_NO_UTF16_FILTER
12633 static I32
12634 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12635 {
12636     dVAR;
12637     const STRLEN old = SvCUR(sv);
12638     const I32 count = FILTER_READ(idx+1, sv, maxlen);
12639     DEBUG_P(PerlIO_printf(Perl_debug_log,
12640                           "utf16_textfilter(%p): %d %d (%d)\n",
12641                           FPTR2DPTR(void *, utf16_textfilter),
12642                           idx, maxlen, (int) count));
12643     if (count) {
12644         U8* tmps;
12645         I32 newlen;
12646         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12647         Copy(SvPVX_const(sv), tmps, old, char);
12648         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12649                       SvCUR(sv) - old, &newlen);
12650         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12651     }
12652     DEBUG_P({sv_dump(sv);});
12653     return SvCUR(sv);
12654 }
12655
12656 static I32
12657 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
12658 {
12659     dVAR;
12660     const STRLEN old = SvCUR(sv);
12661     const I32 count = FILTER_READ(idx+1, sv, maxlen);
12662     DEBUG_P(PerlIO_printf(Perl_debug_log,
12663                           "utf16rev_textfilter(%p): %d %d (%d)\n",
12664                           FPTR2DPTR(void *, utf16rev_textfilter),
12665                           idx, maxlen, (int) count));
12666     if (count) {
12667         U8* tmps;
12668         I32 newlen;
12669         Newx(tmps, SvCUR(sv) * 3 / 2 + 1, U8);
12670         Copy(SvPVX_const(sv), tmps, old, char);
12671         utf16_to_utf8((U8*)SvPVX_const(sv) + old, tmps + old,
12672                       SvCUR(sv) - old, &newlen);
12673         sv_usepvn(sv, (char*)tmps, (STRLEN)newlen + old);
12674     }
12675     DEBUG_P({ sv_dump(sv); });
12676     return count;
12677 }
12678 #endif
12679
12680 /*
12681 Returns a pointer to the next character after the parsed
12682 vstring, as well as updating the passed in sv.
12683
12684 Function must be called like
12685
12686         sv = newSV(5);
12687         s = scan_vstring(s,sv);
12688
12689 The sv should already be large enough to store the vstring
12690 passed in, for performance reasons.
12691
12692 */
12693
12694 char *
12695 Perl_scan_vstring(pTHX_ const char *s, SV *sv)
12696 {
12697     dVAR;
12698     const char *pos = s;
12699     const char *start = s;
12700     if (*pos == 'v') pos++;  /* get past 'v' */
12701     while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12702         pos++;
12703     if ( *pos != '.') {
12704         /* this may not be a v-string if followed by => */
12705         const char *next = pos;
12706         while (next < PL_bufend && isSPACE(*next))
12707             ++next;
12708         if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
12709             /* return string not v-string */
12710             sv_setpvn(sv,(char *)s,pos-s);
12711             return (char *)pos;
12712         }
12713     }
12714
12715     if (!isALPHA(*pos)) {
12716         U8 tmpbuf[UTF8_MAXBYTES+1];
12717
12718         if (*s == 'v')
12719             s++;  /* get past 'v' */
12720
12721         sv_setpvn(sv, "", 0);
12722
12723         for (;;) {
12724             /* this is atoi() that tolerates underscores */
12725             U8 *tmpend;
12726             UV rev = 0;
12727             const char *end = pos;
12728             UV mult = 1;
12729             while (--end >= s) {
12730                 if (*end != '_') {
12731                     const UV orev = rev;
12732                     rev += (*end - '0') * mult;
12733                     mult *= 10;
12734                     if (orev > rev && ckWARN_d(WARN_OVERFLOW))
12735                         Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
12736                                     "Integer overflow in decimal number");
12737                 }
12738             }
12739 #ifdef EBCDIC
12740             if (rev > 0x7FFFFFFF)
12741                  Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
12742 #endif
12743             /* Append native character for the rev point */
12744             tmpend = uvchr_to_utf8(tmpbuf, rev);
12745             sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
12746             if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
12747                  SvUTF8_on(sv);
12748             if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
12749                  s = ++pos;
12750             else {
12751                  s = pos;
12752                  break;
12753             }
12754             while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
12755                  pos++;
12756         }
12757         SvPOK_on(sv);
12758         sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
12759         SvRMAGICAL_on(sv);
12760     }
12761     return (char *)s;
12762 }
12763
12764 /*
12765  * Local variables:
12766  * c-indentation-style: bsd
12767  * c-basic-offset: 4
12768  * indent-tabs-mode: t
12769  * End:
12770  *
12771  * ex: set ts=8 sts=4 sw=4 noet:
12772  */