toke.c

   1 /*    toke.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *   "It all comes from here, the stench and the peril."  --Frodo
  13  */
  14
  15 /*
  16  * This file is the lexer for Perl.  It's closely linked to the
  17  * parser, perly.y.
  18  *
  19  * The main routine is yylex(), which returns the next token.
  20  */
  21
  22 #include "EXTERN.h"
  23 #define PERL_IN_TOKE_C
  24 #include "perl.h"
  25
  26 #define yychar  PL_yychar
  27 #define yylval  PL_yylval
  28
  29 static char ident_too_long[] = "Identifier too long";
  30 static char c_without_g[] = "Use of /c modifier is meaningless without /g";
  31 static char c_in_subst[] = "Use of /c modifier is meaningless in s///";
  32
  33 static void restore_rsfp(pTHX_ void *f);
  34 #ifndef PERL_NO_UTF16_FILTER
  35 static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  36 static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
  37 #endif
  38
  39 #define XFAKEBRACK 128
  40 #define XENUMMASK 127
  41
  42 #ifdef USE_UTF8_SCRIPTS
  43 #   define UTF (!IN_BYTES)
  44 #else
  45 #   define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8))
  46 #endif
  47
  48 /* In variables named $^X, these are the legal values for X.
  49  * 1999-02-27 mjd-perl-patch@plover.com */
  50 #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x)))
  51
  52 /* On MacOS, respect nonbreaking spaces */
  53 #ifdef MACOS_TRADITIONAL
  54 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t')
  55 #else
  56 #define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t')
  57 #endif
  58
  59 /* LEX_* are values for PL_lex_state, the state of the lexer.
  60  * They are arranged oddly so that the guard on the switch statement
  61  * can get by with a single comparison (if the compiler is smart enough).
  62  */
  63
  64 /* #define LEX_NOTPARSING               11 is done in perl.h. */
  65
  66 #define LEX_NORMAL              10
  67 #define LEX_INTERPNORMAL         9
  68 #define LEX_INTERPCASEMOD        8
  69 #define LEX_INTERPPUSH           7
  70 #define LEX_INTERPSTART          6
  71 #define LEX_INTERPEND            5
  72 #define LEX_INTERPENDMAYBE       4
  73 #define LEX_INTERPCONCAT         3
  74 #define LEX_INTERPCONST          2
  75 #define LEX_FORMLINE             1
  76 #define LEX_KNOWNEXT             0
  77
  78 #ifdef ff_next
  79 #undef ff_next
  80 #endif
  81
  82 #ifdef USE_PURE_BISON
  83 #  ifndef YYMAXLEVEL
  84 #    define YYMAXLEVEL 100
  85 #  endif
  86 YYSTYPE* yylval_pointer[YYMAXLEVEL];
  87 int* yychar_pointer[YYMAXLEVEL];
  88 int yyactlevel = -1;
  89 #  undef yylval
  90 #  undef yychar
  91 #  define yylval (*yylval_pointer[yyactlevel])
  92 #  define yychar (*yychar_pointer[yyactlevel])
  93 #  define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]
  94 #  undef yylex
  95 #  define yylex()      Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel])
  96 #endif
  97
  98 #include "keywords.h"
  99
 100 /* CLINE is a macro that ensures PL_copline has a sane value */
 101
 102 #ifdef CLINE
 103 #undef CLINE
 104 #endif
 105 #define CLINE (PL_copline = (CopLINE(PL_curcop) < PL_copline ? CopLINE(PL_curcop) : PL_copline))
 106
 107 /*
 108  * Convenience functions to return different tokens and prime the
 109  * lexer for the next token.  They all take an argument.
 110  *
 111  * TOKEN        : generic token (used for '(', DOLSHARP, etc)
 112  * OPERATOR     : generic operator
 113  * AOPERATOR    : assignment operator
 114  * PREBLOCK     : beginning the block after an if, while, foreach, ...
 115  * PRETERMBLOCK : beginning a non-code-defining {} block (eg, hash ref)
 116  * PREREF       : *EXPR where EXPR is not a simple identifier
 117  * TERM         : expression term
 118  * LOOPX        : loop exiting command (goto, last, dump, etc)
 119  * FTST         : file test operator
 120  * FUN0         : zero-argument function
 121  * FUN1         : not used, except for not, which isn't a UNIOP
 122  * BOop         : bitwise or or xor
 123  * BAop         : bitwise and
 124  * SHop         : shift operator
 125  * PWop         : power operator
 126  * PMop         : pattern-matching operator
 127  * Aop          : addition-level operator
 128  * Mop          : multiplication-level operator
 129  * Eop          : equality-testing operator
 130  * Rop          : relational operator <= != gt
 131  *
 132  * Also see LOP and lop() below.
 133  */
 134
 135 /* Note that REPORT() and REPORT2() will be expressions that supply
 136  * their own trailing comma, not suitable for statements as such. */
 137 #ifdef DEBUGGING /* Serve -DT. */
 138 #   define REPORT(x,retval) tokereport(x,s,(int)retval),
 139 #   define REPORT2(x,retval) tokereport(x,s, yylval.ival),
 140 #else
 141 #   define REPORT(x,retval)
 142 #   define REPORT2(x,retval)
 143 #endif
 144
 145 #define TOKEN(retval) return (REPORT2("token",retval) PL_bufptr = s,(int)retval)
 146 #define OPERATOR(retval) return (REPORT2("operator",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval)
 147 #define AOPERATOR(retval) return ao((REPORT2("aop",retval) PL_expect = XTERM, PL_bufptr = s,(int)retval))
 148 #define PREBLOCK(retval) return (REPORT2("preblock",retval) PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
 149 #define PRETERMBLOCK(retval) return (REPORT2("pretermblock",retval) PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
 150 #define PREREF(retval) return (REPORT2("preref",retval) PL_expect = XREF,PL_bufptr = s,(int)retval)
 151 #define TERM(retval) return (CLINE, REPORT2("term",retval) PL_expect = XOPERATOR, PL_bufptr = s,(int)retval)
 152 #define LOOPX(f) return(yylval.ival=f, REPORT("loopx",f) PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
 153 #define FTST(f) return(yylval.ival=f, REPORT("ftst",f) PL_expect = XTERMORDORDOR,PL_bufptr = s,(int)UNIOP)
 154 #define FUN0(f) return(yylval.ival = f, REPORT("fun0",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
 155 #define FUN1(f) return(yylval.ival = f, REPORT("fun1",f) PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
 156 #define BOop(f) return ao((yylval.ival=f, REPORT("bitorop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
 157 #define BAop(f) return ao((yylval.ival=f, REPORT("bitandop",f) PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
 158 #define SHop(f) return ao((yylval.ival=f, REPORT("shiftop",f) PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
 159 #define PWop(f) return ao((yylval.ival=f, REPORT("powop",f) PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
 160 #define PMop(f) return(yylval.ival=f, REPORT("matchop",f) PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
 161 #define Aop(f) return ao((yylval.ival=f, REPORT("add",f) PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
 162 #define Mop(f) return ao((yylval.ival=f, REPORT("mul",f) PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
 163 #define Eop(f) return(yylval.ival=f, REPORT("eq",f) PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
 164 #define Rop(f) return(yylval.ival=f, REPORT("rel",f) PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
 165
 166 /* This bit of chicanery makes a unary function followed by
 167  * a parenthesis into a function with one argument, highest precedence.
 168  * The UNIDOR macro is for unary functions that can be followed by the //
 169  * operator (such as C<shift // 0>).
 170  */
 171 #define UNI2(f,x) return(yylval.ival = f, \
 172         REPORT("uni",f) \
 173         PL_expect = x, \
 174         PL_bufptr = s, \
 175         PL_last_uni = PL_oldbufptr, \
 176         PL_last_lop_op = f, \
 177         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 178 #define UNI(f)    UNI2(f,XTERM)
 179 #define UNIDOR(f) UNI2(f,XTERMORDORDOR)
 180
 181 #define UNIBRACK(f) return(yylval.ival = f, \
 182         REPORT("uni",f) \
 183         PL_bufptr = s, \
 184         PL_last_uni = PL_oldbufptr, \
 185         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 186
 187 /* grandfather return to old style */
 188 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
 189
 190 #ifdef DEBUGGING
 191
 192 STATIC void
 193 S_tokereport(pTHX_ char *thing, char* s, I32 rv)
 194 {
 195     DEBUG_T({
 196         SV* report = newSVpv(thing, 0);
 197         Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop),
 198                 (IV)rv);
 199
 200         if (s - PL_bufptr > 0)
 201             sv_catpvn(report, PL_bufptr, s - PL_bufptr);
 202         else {
 203             if (PL_oldbufptr && *PL_oldbufptr)
 204                 sv_catpv(report, PL_tokenbuf);
 205         }
 206         PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report));
 207     });
 208 }
 209
 210 #endif
 211
 212 /*
 213  * S_ao
 214  *
 215  * This subroutine detects &&=, ||=, and //= and turns an ANDAND, OROR or DORDOR
 216  * into an OP_ANDASSIGN, OP_ORASSIGN, or OP_DORASSIGN
 217  */
 218
 219 STATIC int
 220 S_ao(pTHX_ int toketype)
 221 {
 222     if (*PL_bufptr == '=') {
 223         PL_bufptr++;
 224         if (toketype == ANDAND)
 225             yylval.ival = OP_ANDASSIGN;
 226         else if (toketype == OROR)
 227             yylval.ival = OP_ORASSIGN;
 228         else if (toketype == DORDOR)
 229             yylval.ival = OP_DORASSIGN;
 230         toketype = ASSIGNOP;
 231     }
 232     return toketype;
 233 }
 234
 235 /*
 236  * S_no_op
 237  * When Perl expects an operator and finds something else, no_op
 238  * prints the warning.  It always prints "<something> found where
 239  * operator expected.  It prints "Missing semicolon on previous line?"
 240  * if the surprise occurs at the start of the line.  "do you need to
 241  * predeclare ..." is printed out for code like "sub bar; foo bar $x"
 242  * where the compiler doesn't know if foo is a method call or a function.
 243  * It prints "Missing operator before end of line" if there's nothing
 244  * after the missing operator, or "... before <...>" if there is something
 245  * after the missing operator.
 246  */
 247
 248 STATIC void
 249 S_no_op(pTHX_ char *what, char *s)
 250 {
 251     char *oldbp = PL_bufptr;
 252     bool is_first = (PL_oldbufptr == PL_linestart);
 253
 254     if (!s)
 255         s = oldbp;
 256     else
 257         PL_bufptr = s;
 258     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
 259     if (ckWARN_d(WARN_SYNTAX)) {
 260         if (is_first)
 261             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 262                     "\t(Missing semicolon on previous line?)\n");
 263         else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) {
 264             char *t;
 265             for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ;
 266             if (t < PL_bufptr && isSPACE(*t))
 267                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 268                         "\t(Do you need to predeclare %.*s?)\n",
 269                     t - PL_oldoldbufptr, PL_oldoldbufptr);
 270         }
 271         else {
 272             assert(s >= oldbp);
 273             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 274                     "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
 275         }
 276     }
 277     PL_bufptr = oldbp;
 278 }
 279
 280 /*
 281  * S_missingterm
 282  * Complain about missing quote/regexp/heredoc terminator.
 283  * If it's called with (char *)NULL then it cauterizes the line buffer.
 284  * If we're in a delimited string and the delimiter is a control
 285  * character, it's reformatted into a two-char sequence like ^C.
 286  * This is fatal.
 287  */
 288
 289 STATIC void
 290 S_missingterm(pTHX_ char *s)
 291 {
 292     char tmpbuf[3];
 293     char q;
 294     if (s) {
 295         char *nl = strrchr(s,'\n');
 296         if (nl)
 297             *nl = '\0';
 298     }
 299     else if (
 300 #ifdef EBCDIC
 301         iscntrl(PL_multi_close)
 302 #else
 303         PL_multi_close < 32 || PL_multi_close == 127
 304 #endif
 305         ) {
 306         *tmpbuf = '^';
 307         tmpbuf[1] = toCTRL(PL_multi_close);
 308         s = "\\n";
 309         tmpbuf[2] = '\0';
 310         s = tmpbuf;
 311     }
 312     else {
 313         *tmpbuf = (char)PL_multi_close;
 314         tmpbuf[1] = '\0';
 315         s = tmpbuf;
 316     }
 317     q = strchr(s,'"') ? '\'' : '"';
 318     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 319 }
 320
 321 /*
 322  * Perl_deprecate
 323  */
 324
 325 void
 326 Perl_deprecate(pTHX_ char *s)
 327 {
 328     if (ckWARN(WARN_DEPRECATED))
 329         Perl_warner(aTHX_ packWARN(WARN_DEPRECATED), "Use of %s is deprecated", s);
 330 }
 331
 332 void
 333 Perl_deprecate_old(pTHX_ char *s)
 334 {
 335     /* This function should NOT be called for any new deprecated warnings */
 336     /* Use Perl_deprecate instead                                         */
 337     /*                                                                    */
 338     /* It is here to maintain backward compatibility with the pre-5.8     */
 339     /* warnings category hierarchy. The "deprecated" category used to     */
 340     /* live under the "syntax" category. It is now a top-level category   */
 341     /* in its own right.                                                  */
 342
 343     if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
 344         Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
 345                         "Use of %s is deprecated", s);
 346 }
 347
 348 /*
 349  * depcom
 350  * Deprecate a comma-less variable list.
 351  */
 352
 353 STATIC void
 354 S_depcom(pTHX)
 355 {
 356     deprecate_old("comma-less variable list");
 357 }
 358
 359 /*
 360  * experimental text filters for win32 carriage-returns, utf16-to-utf8 and
 361  * utf16-to-utf8-reversed.
 362  */
 363
 364 #ifdef PERL_CR_FILTER
 365 static void
 366 strip_return(SV *sv)
 367 {
 368     register char *s = SvPVX(sv);
 369     register char *e = s + SvCUR(sv);
 370     /* outer loop optimized to do nothing if there are no CR-LFs */
 371     while (s < e) {
 372         if (*s++ == '\r' && *s == '\n') {
 373             /* hit a CR-LF, need to copy the rest */
 374             register char *d = s - 1;
 375             *d++ = *s++;
 376             while (s < e) {
 377                 if (*s == '\r' && s[1] == '\n')
 378                     s++;
 379                 *d++ = *s++;
 380             }
 381             SvCUR(sv) -= s - d;
 382             return;
 383         }
 384     }
 385 }
 386
 387 STATIC I32
 388 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 389 {
 390     I32 count = FILTER_READ(idx+1, sv, maxlen);
 391     if (count > 0 && !maxlen)
 392         strip_return(sv);
 393     return count;
 394 }
 395 #endif
 396
 397 /*
 398  * Perl_lex_start
 399  * Initialize variables.  Uses the Perl save_stack to save its state (for
 400  * recursive calls to the parser).
 401  */
 402
 403 void
 404 Perl_lex_start(pTHX_ SV *line)
 405 {
 406     char *s;
 407     STRLEN len;
 408
 409     SAVEI32(PL_lex_dojoin);
 410     SAVEI32(PL_lex_brackets);
 411     SAVEI32(PL_lex_casemods);
 412     SAVEI32(PL_lex_starts);
 413     SAVEI32(PL_lex_state);
 414     SAVEVPTR(PL_lex_inpat);
 415     SAVEI32(PL_lex_inwhat);
 416     if (PL_lex_state == LEX_KNOWNEXT) {
 417         I32 toke = PL_nexttoke;
 418         while (--toke >= 0) {
 419             SAVEI32(PL_nexttype[toke]);
 420             SAVEVPTR(PL_nextval[toke]);
 421         }
 422         SAVEI32(PL_nexttoke);
 423     }
 424     SAVECOPLINE(PL_curcop);
 425     SAVEPPTR(PL_bufptr);
 426     SAVEPPTR(PL_bufend);
 427     SAVEPPTR(PL_oldbufptr);
 428     SAVEPPTR(PL_oldoldbufptr);
 429     SAVEPPTR(PL_last_lop);
 430     SAVEPPTR(PL_last_uni);
 431     SAVEPPTR(PL_linestart);
 432     SAVESPTR(PL_linestr);
 433     SAVEGENERICPV(PL_lex_brackstack);
 434     SAVEGENERICPV(PL_lex_casestack);
 435     SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
 436     SAVESPTR(PL_lex_stuff);
 437     SAVEI32(PL_lex_defer);
 438     SAVEI32(PL_sublex_info.sub_inwhat);
 439     SAVESPTR(PL_lex_repl);
 440     SAVEINT(PL_expect);
 441     SAVEINT(PL_lex_expect);
 442
 443     PL_lex_state = LEX_NORMAL;
 444     PL_lex_defer = 0;
 445     PL_expect = XSTATE;
 446     PL_lex_brackets = 0;
 447     New(899, PL_lex_brackstack, 120, char);
 448     New(899, PL_lex_casestack, 12, char);
 449     PL_lex_casemods = 0;
 450     *PL_lex_casestack = '\0';
 451     PL_lex_dojoin = 0;
 452     PL_lex_starts = 0;
 453     PL_lex_stuff = Nullsv;
 454     PL_lex_repl = Nullsv;
 455     PL_lex_inpat = 0;
 456     PL_nexttoke = 0;
 457     PL_lex_inwhat = 0;
 458     PL_sublex_info.sub_inwhat = 0;
 459     PL_linestr = line;
 460     if (SvREADONLY(PL_linestr))
 461         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 462     s = SvPV(PL_linestr, len);
 463     if (!len || s[len-1] != ';') {
 464         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
 465             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 466         sv_catpvn(PL_linestr, "\n;", 2);
 467     }
 468     SvTEMP_off(PL_linestr);
 469     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
 470     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
 471     PL_last_lop = PL_last_uni = Nullch;
 472     PL_rsfp = 0;
 473 }
 474
 475 /*
 476  * Perl_lex_end
 477  * Finalizer for lexing operations.  Must be called when the parser is
 478  * done with the lexer.
 479  */
 480
 481 void
 482 Perl_lex_end(pTHX)
 483 {
 484     PL_doextract = FALSE;
 485 }
 486
 487 /*
 488  * S_incline
 489  * This subroutine has nothing to do with tilting, whether at windmills
 490  * or pinball tables.  Its name is short for "increment line".  It
 491  * increments the current line number in CopLINE(PL_curcop) and checks
 492  * to see whether the line starts with a comment of the form
 493  *    # line 500 "foo.pm"
 494  * If so, it sets the current line number and file to the values in the comment.
 495  */
 496
 497 STATIC void
 498 S_incline(pTHX_ char *s)
 499 {
 500     char *t;
 501     char *n;
 502     char *e;
 503     char ch;
 504
 505     CopLINE_inc(PL_curcop);
 506     if (*s++ != '#')
 507         return;
 508     while (SPACE_OR_TAB(*s)) s++;
 509     if (strnEQ(s, "line", 4))
 510         s += 4;
 511     else
 512         return;
 513     if (SPACE_OR_TAB(*s))
 514         s++;
 515     else
 516         return;
 517     while (SPACE_OR_TAB(*s)) s++;
 518     if (!isDIGIT(*s))
 519         return;
 520     n = s;
 521     while (isDIGIT(*s))
 522         s++;
 523     while (SPACE_OR_TAB(*s))
 524         s++;
 525     if (*s == '"' && (t = strchr(s+1, '"'))) {
 526         s++;
 527         e = t + 1;
 528     }
 529     else {
 530         for (t = s; !isSPACE(*t); t++) ;
 531         e = t;
 532     }
 533     while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f')
 534         e++;
 535     if (*e != '\n' && *e != '\0')
 536         return;         /* false alarm */
 537
 538     ch = *t;
 539     *t = '\0';
 540     if (t - s > 0) {
 541         CopFILE_free(PL_curcop);
 542         CopFILE_set(PL_curcop, s);
 543     }
 544     *t = ch;
 545     CopLINE_set(PL_curcop, atoi(n)-1);
 546 }
 547
 548 /*
 549  * S_skipspace
 550  * Called to gobble the appropriate amount and type of whitespace.
 551  * Skips comments as well.
 552  */
 553
 554 STATIC char *
 555 S_skipspace(pTHX_ register char *s)
 556 {
 557     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 558         while (s < PL_bufend && SPACE_OR_TAB(*s))
 559             s++;
 560         return s;
 561     }
 562     for (;;) {
 563         STRLEN prevlen;
 564         SSize_t oldprevlen, oldoldprevlen;
 565         SSize_t oldloplen = 0, oldunilen = 0;
 566         while (s < PL_bufend && isSPACE(*s)) {
 567             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
 568                 incline(s);
 569         }
 570
 571         /* comment */
 572         if (s < PL_bufend && *s == '#') {
 573             while (s < PL_bufend && *s != '\n')
 574                 s++;
 575             if (s < PL_bufend) {
 576                 s++;
 577                 if (PL_in_eval && !PL_rsfp) {
 578                     incline(s);
 579                     continue;
 580                 }
 581             }
 582         }
 583
 584         /* only continue to recharge the buffer if we're at the end
 585          * of the buffer, we're not reading from a source filter, and
 586          * we're in normal lexing mode
 587          */
 588         if (s < PL_bufend || !PL_rsfp || PL_sublex_info.sub_inwhat ||
 589                 PL_lex_state == LEX_FORMLINE)
 590             return s;
 591
 592         /* try to recharge the buffer */
 593         if ((s = filter_gets(PL_linestr, PL_rsfp,
 594                              (prevlen = SvCUR(PL_linestr)))) == Nullch)
 595         {
 596             /* end of file.  Add on the -p or -n magic */
 597             if (PL_minus_n || PL_minus_p) {
 598                 sv_setpv(PL_linestr,PL_minus_p ?
 599                          ";}continue{print or die qq(-p destination: $!\\n)" :
 600                          "");
 601                 sv_catpv(PL_linestr,";}");
 602                 PL_minus_n = PL_minus_p = 0;
 603             }
 604             else
 605                 sv_setpv(PL_linestr,";");
 606
 607             /* reset variables for next time we lex */
 608             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart
 609                 = SvPVX(PL_linestr);
 610             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
 611             PL_last_lop = PL_last_uni = Nullch;
 612
 613             /* Close the filehandle.  Could be from -P preprocessor,
 614              * STDIN, or a regular file.  If we were reading code from
 615              * STDIN (because the commandline held no -e or filename)
 616              * then we don't close it, we reset it so the code can
 617              * read from STDIN too.
 618              */
 619
 620             if (PL_preprocess && !PL_in_eval)
 621                 (void)PerlProc_pclose(PL_rsfp);
 622             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
 623                 PerlIO_clearerr(PL_rsfp);
 624             else
 625                 (void)PerlIO_close(PL_rsfp);
 626             PL_rsfp = Nullfp;
 627             return s;
 628         }
 629
 630         /* not at end of file, so we only read another line */
 631         /* make corresponding updates to old pointers, for yyerror() */
 632         oldprevlen = PL_oldbufptr - PL_bufend;
 633         oldoldprevlen = PL_oldoldbufptr - PL_bufend;
 634         if (PL_last_uni)
 635             oldunilen = PL_last_uni - PL_bufend;
 636         if (PL_last_lop)
 637             oldloplen = PL_last_lop - PL_bufend;
 638         PL_linestart = PL_bufptr = s + prevlen;
 639         PL_bufend = s + SvCUR(PL_linestr);
 640         s = PL_bufptr;
 641         PL_oldbufptr = s + oldprevlen;
 642         PL_oldoldbufptr = s + oldoldprevlen;
 643         if (PL_last_uni)
 644             PL_last_uni = s + oldunilen;
 645         if (PL_last_lop)
 646             PL_last_lop = s + oldloplen;
 647         incline(s);
 648
 649         /* debugger active and we're not compiling the debugger code,
 650          * so store the line into the debugger's array of lines
 651          */
 652         if (PERLDB_LINE && PL_curstash != PL_debstash) {
 653             SV *sv = NEWSV(85,0);
 654
 655             sv_upgrade(sv, SVt_PVMG);
 656             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
 657             (void)SvIOK_on(sv);
 658             SvIVX(sv) = 0;
 659             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
 660         }
 661     }
 662 }
 663
 664 /*
 665  * S_check_uni
 666  * Check the unary operators to ensure there's no ambiguity in how they're
 667  * used.  An ambiguous piece of code would be:
 668  *     rand + 5
 669  * This doesn't mean rand() + 5.  Because rand() is a unary operator,
 670  * the +5 is its argument.
 671  */
 672
 673 STATIC void
 674 S_check_uni(pTHX)
 675 {
 676     char *s;
 677     char *t;
 678
 679     if (PL_oldoldbufptr != PL_last_uni)
 680         return;
 681     while (isSPACE(*PL_last_uni))
 682         PL_last_uni++;
 683     for (s = PL_last_uni; isALNUM_lazy_if(s,UTF) || *s == '-'; s++) ;
 684     if ((t = strchr(s, '(')) && t < PL_bufptr)
 685         return;
 686     if (ckWARN_d(WARN_AMBIGUOUS)){
 687         char ch = *s;
 688         *s = '\0';
 689         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
 690                    "Warning: Use of \"%s\" without parentheses is ambiguous",
 691                    PL_last_uni);
 692         *s = ch;
 693     }
 694 }
 695
 696 /*
 697  * LOP : macro to build a list operator.  Its behaviour has been replaced
 698  * with a subroutine, S_lop() for which LOP is just another name.
 699  */
 700
 701 #define LOP(f,x) return lop(f,x,s)
 702
 703 /*
 704  * S_lop
 705  * Build a list operator (or something that might be one).  The rules:
 706  *  - if we have a next token, then it's a list operator [why?]
 707  *  - if the next thing is an opening paren, then it's a function
 708  *  - else it's a list operator
 709  */
 710
 711 STATIC I32
 712 S_lop(pTHX_ I32 f, int x, char *s)
 713 {
 714     yylval.ival = f;
 715     CLINE;
 716     REPORT("lop", f)
 717     PL_expect = x;
 718     PL_bufptr = s;
 719     PL_last_lop = PL_oldbufptr;
 720     PL_last_lop_op = (OPCODE)f;
 721     if (PL_nexttoke)
 722         return LSTOP;
 723     if (*s == '(')
 724         return FUNC;
 725     s = skipspace(s);
 726     if (*s == '(')
 727         return FUNC;
 728     else
 729         return LSTOP;
 730 }
 731
 732 /*
 733  * S_force_next
 734  * When the lexer realizes it knows the next token (for instance,
 735  * it is reordering tokens for the parser) then it can call S_force_next
 736  * to know what token to return the next time the lexer is called.  Caller
 737  * will need to set PL_nextval[], and possibly PL_expect to ensure the lexer
 738  * handles the token correctly.
 739  */
 740
 741 STATIC void
 742 S_force_next(pTHX_ I32 type)
 743 {
 744     PL_nexttype[PL_nexttoke] = type;
 745     PL_nexttoke++;
 746     if (PL_lex_state != LEX_KNOWNEXT) {
 747         PL_lex_defer = PL_lex_state;
 748         PL_lex_expect = PL_expect;
 749         PL_lex_state = LEX_KNOWNEXT;
 750     }
 751 }
 752
 753 /*
 754  * S_force_word
 755  * When the lexer knows the next thing is a word (for instance, it has
 756  * just seen -> and it knows that the next char is a word char, then
 757  * it calls S_force_word to stick the next word into the PL_next lookahead.
 758  *
 759  * Arguments:
 760  *   char *start : buffer position (must be within PL_linestr)
 761  *   int token   : PL_next will be this type of bare word (e.g., METHOD,WORD)
 762  *   int check_keyword : if true, Perl checks to make sure the word isn't
 763  *       a keyword (do this if the word is a label, e.g. goto FOO)
 764  *   int allow_pack : if true, : characters will also be allowed (require,
 765  *       use, etc. do this)
 766  *   int allow_initial_tick : used by the "sub" lexer only.
 767  */
 768
 769 STATIC char *
 770 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
 771 {
 772     register char *s;
 773     STRLEN len;
 774
 775     start = skipspace(start);
 776     s = start;
 777     if (isIDFIRST_lazy_if(s,UTF) ||
 778         (allow_pack && *s == ':') ||
 779         (allow_initial_tick && *s == '\'') )
 780     {
 781         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
 782         if (check_keyword && keyword(PL_tokenbuf, len))
 783             return start;
 784         if (token == METHOD) {
 785             s = skipspace(s);
 786             if (*s == '(')
 787                 PL_expect = XTERM;
 788             else {
 789                 PL_expect = XOPERATOR;
 790             }
 791         }
 792         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
 793         PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
 794         if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
 795             SvUTF8_on(((SVOP*)PL_nextval[PL_nexttoke].opval)->op_sv);
 796         force_next(token);
 797     }
 798     return s;
 799 }
 800
 801 /*
 802  * S_force_ident
 803  * Called when the lexer wants $foo *foo &foo etc, but the program
 804  * text only contains the "foo" portion.  The first argument is a pointer
 805  * to the "foo", and the second argument is the type symbol to prefix.
 806  * Forces the next token to be a "WORD".
 807  * Creates the symbol if it didn't already exist (via gv_fetchpv()).
 808  */
 809
 810 STATIC void
 811 S_force_ident(pTHX_ register char *s, int kind)
 812 {
 813     if (s && *s) {
 814         OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
 815         PL_nextval[PL_nexttoke].opval = o;
 816         force_next(WORD);
 817         if (kind) {
 818             o->op_private = OPpCONST_ENTERED;
 819             /* XXX see note in pp_entereval() for why we forgo typo
 820                warnings if the symbol must be introduced in an eval.
 821                GSAR 96-10-12 */
 822             gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
 823                 kind == '$' ? SVt_PV :
 824                 kind == '@' ? SVt_PVAV :
 825                 kind == '%' ? SVt_PVHV :
 826                               SVt_PVGV
 827                 );
 828         }
 829     }
 830 }
 831
 832 NV
 833 Perl_str_to_version(pTHX_ SV *sv)
 834 {
 835     NV retval = 0.0;
 836     NV nshift = 1.0;
 837     STRLEN len;
 838     char *start = SvPVx(sv,len);
 839     bool utf = SvUTF8(sv) ? TRUE : FALSE;
 840     char *end = start + len;
 841     while (start < end) {
 842         STRLEN skip;
 843         UV n;
 844         if (utf)
 845             n = utf8n_to_uvchr((U8*)start, len, &skip, 0);
 846         else {
 847             n = *(U8*)start;
 848             skip = 1;
 849         }
 850         retval += ((NV)n)/nshift;
 851         start += skip;
 852         nshift *= 1000;
 853     }
 854     return retval;
 855 }
 856
 857 /*
 858  * S_force_version
 859  * Forces the next token to be a version number.
 860  * If the next token appears to be an invalid version number, (e.g. "v2b"),
 861  * and if "guessing" is TRUE, then no new token is created (and the caller
 862  * must use an alternative parsing method).
 863  */
 864
 865 STATIC char *
 866 S_force_version(pTHX_ char *s, int guessing)
 867 {
 868     OP *version = Nullop;
 869     char *d;
 870
 871     s = skipspace(s);
 872
 873     d = s;
 874     if (*d == 'v')
 875         d++;
 876     if (isDIGIT(*d)) {
 877         while (isDIGIT(*d) || *d == '_' || *d == '.')
 878             d++;
 879         if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) {
 880             SV *ver;
 881             s = scan_num(s, &yylval);
 882             version = yylval.opval;
 883             ver = cSVOPx(version)->op_sv;
 884             if (SvPOK(ver) && !SvNIOK(ver)) {
 885                 (void)SvUPGRADE(ver, SVt_PVNV);
 886                 SvNVX(ver) = str_to_version(ver);
 887                 SvNOK_on(ver);          /* hint that it is a version */
 888             }
 889         }
 890         else if (guessing)
 891             return s;
 892     }
 893
 894     /* NOTE: The parser sees the package name and the VERSION swapped */
 895     PL_nextval[PL_nexttoke].opval = version;
 896     force_next(WORD);
 897
 898     return s;
 899 }
 900
 901 /*
 902  * S_tokeq
 903  * Tokenize a quoted string passed in as an SV.  It finds the next
 904  * chunk, up to end of string or a backslash.  It may make a new
 905  * SV containing that chunk (if HINT_NEW_STRING is on).  It also
 906  * turns \\ into \.
 907  */
 908
 909 STATIC SV *
 910 S_tokeq(pTHX_ SV *sv)
 911 {
 912     register char *s;
 913     register char *send;
 914     register char *d;
 915     STRLEN len = 0;
 916     SV *pv = sv;
 917
 918     if (!SvLEN(sv))
 919         goto finish;
 920
 921     s = SvPV_force(sv, len);
 922     if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1)
 923         goto finish;
 924     send = s + len;
 925     while (s < send && *s != '\\')
 926         s++;
 927     if (s == send)
 928         goto finish;
 929     d = s;
 930     if ( PL_hints & HINT_NEW_STRING ) {
 931         pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
 932         if (SvUTF8(sv))
 933             SvUTF8_on(pv);
 934     }
 935     while (s < send) {
 936         if (*s == '\\') {
 937             if (s + 1 < send && (s[1] == '\\'))
 938                 s++;            /* all that, just for this */
 939         }
 940         *d++ = *s++;
 941     }
 942     *d = '\0';
 943     SvCUR_set(sv, d - SvPVX(sv));
 944   finish:
 945     if ( PL_hints & HINT_NEW_STRING )
 946        return new_constant(NULL, 0, "q", sv, pv, "q");
 947     return sv;
 948 }
 949
 950 /*
 951  * Now come three functions related to double-quote context,
 952  * S_sublex_start, S_sublex_push, and S_sublex_done.  They're used when
 953  * converting things like "\u\Lgnat" into ucfirst(lc("gnat")).  They
 954  * interact with PL_lex_state, and create fake ( ... ) argument lists
 955  * to handle functions and concatenation.
 956  * They assume that whoever calls them will be setting up a fake
 957  * join call, because each subthing puts a ',' after it.  This lets
 958  *   "lower \luPpEr"
 959  * become
 960  *  join($, , 'lower ', lcfirst( 'uPpEr', ) ,)
 961  *
 962  * (I'm not sure whether the spurious commas at the end of lcfirst's
 963  * arguments and join's arguments are created or not).
 964  */
 965
 966 /*
 967  * S_sublex_start
 968  * Assumes that yylval.ival is the op we're creating (e.g. OP_LCFIRST).
 969  *
 970  * Pattern matching will set PL_lex_op to the pattern-matching op to
 971  * make (we return THING if yylval.ival is OP_NULL, PMFUNC otherwise).
 972  *
 973  * OP_CONST and OP_READLINE are easy--just make the new op and return.
 974  *
 975  * Everything else becomes a FUNC.
 976  *
 977  * Sets PL_lex_state to LEX_INTERPPUSH unless (ival was OP_NULL or we
 978  * had an OP_CONST or OP_READLINE).  This just sets us up for a
 979  * call to S_sublex_push().
 980  */
 981
 982 STATIC I32
 983 S_sublex_start(pTHX)
 984 {
 985     register I32 op_type = yylval.ival;
 986
 987     if (op_type == OP_NULL) {
 988         yylval.opval = PL_lex_op;
 989         PL_lex_op = Nullop;
 990         return THING;
 991     }
 992     if (op_type == OP_CONST || op_type == OP_READLINE) {
 993         SV *sv = tokeq(PL_lex_stuff);
 994
 995         if (SvTYPE(sv) == SVt_PVIV) {
 996             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
 997             STRLEN len;
 998             char *p;
 999             SV *nsv;
1000
1001             p = SvPV(sv, len);
1002             nsv = newSVpvn(p, len);
1003             if (SvUTF8(sv))
1004                 SvUTF8_on(nsv);
1005             SvREFCNT_dec(sv);
1006             sv = nsv;
1007         }
1008         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
1009         PL_lex_stuff = Nullsv;
1010         /* Allow <FH> // "foo" */
1011         if (op_type == OP_READLINE)
1012             PL_expect = XTERMORDORDOR;
1013         return THING;
1014     }
1015
1016     PL_sublex_info.super_state = PL_lex_state;
1017     PL_sublex_info.sub_inwhat = op_type;
1018     PL_sublex_info.sub_op = PL_lex_op;
1019     PL_lex_state = LEX_INTERPPUSH;
1020
1021     PL_expect = XTERM;
1022     if (PL_lex_op) {
1023         yylval.opval = PL_lex_op;
1024         PL_lex_op = Nullop;
1025         return PMFUNC;
1026     }
1027     else
1028         return FUNC;
1029 }
1030
1031 /*
1032  * S_sublex_push
1033  * Create a new scope to save the lexing state.  The scope will be
1034  * ended in S_sublex_done.  Returns a '(', starting the function arguments
1035  * to the uc, lc, etc. found before.
1036  * Sets PL_lex_state to LEX_INTERPCONCAT.
1037  */
1038
1039 STATIC I32
1040 S_sublex_push(pTHX)
1041 {
1042     ENTER;
1043
1044     PL_lex_state = PL_sublex_info.super_state;
1045     SAVEI32(PL_lex_dojoin);
1046     SAVEI32(PL_lex_brackets);
1047     SAVEI32(PL_lex_casemods);
1048     SAVEI32(PL_lex_starts);
1049     SAVEI32(PL_lex_state);
1050     SAVEVPTR(PL_lex_inpat);
1051     SAVEI32(PL_lex_inwhat);
1052     SAVECOPLINE(PL_curcop);
1053     SAVEPPTR(PL_bufptr);
1054     SAVEPPTR(PL_bufend);
1055     SAVEPPTR(PL_oldbufptr);
1056     SAVEPPTR(PL_oldoldbufptr);
1057     SAVEPPTR(PL_last_lop);
1058     SAVEPPTR(PL_last_uni);
1059     SAVEPPTR(PL_linestart);
1060     SAVESPTR(PL_linestr);
1061     SAVEGENERICPV(PL_lex_brackstack);
1062     SAVEGENERICPV(PL_lex_casestack);
1063
1064     PL_linestr = PL_lex_stuff;
1065     PL_lex_stuff = Nullsv;
1066
1067     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart
1068         = SvPVX(PL_linestr);
1069     PL_bufend += SvCUR(PL_linestr);
1070     PL_last_lop = PL_last_uni = Nullch;
1071     SAVEFREESV(PL_linestr);
1072
1073     PL_lex_dojoin = FALSE;
1074     PL_lex_brackets = 0;
1075     New(899, PL_lex_brackstack, 120, char);
1076     New(899, PL_lex_casestack, 12, char);
1077     PL_lex_casemods = 0;
1078     *PL_lex_casestack = '\0';
1079     PL_lex_starts = 0;
1080     PL_lex_state = LEX_INTERPCONCAT;
1081     CopLINE_set(PL_curcop, (line_t)PL_multi_start);
1082
1083     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
1084     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
1085         PL_lex_inpat = PL_sublex_info.sub_op;
1086     else
1087         PL_lex_inpat = Nullop;
1088
1089     return '(';
1090 }
1091
1092 /*
1093  * S_sublex_done
1094  * Restores lexer state after a S_sublex_push.
1095  */
1096
1097 STATIC I32
1098 S_sublex_done(pTHX)
1099 {
1100     if (!PL_lex_starts++) {
1101         SV *sv = newSVpvn("",0);
1102         if (SvUTF8(PL_linestr))
1103             SvUTF8_on(sv);
1104         PL_expect = XOPERATOR;
1105         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1106         return THING;
1107     }
1108
1109     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
1110         PL_lex_state = LEX_INTERPCASEMOD;
1111         return yylex();
1112     }
1113
1114     /* Is there a right-hand side to take care of? (s//RHS/ or tr//RHS/) */
1115     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
1116         PL_linestr = PL_lex_repl;
1117         PL_lex_inpat = 0;
1118         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
1119         PL_bufend += SvCUR(PL_linestr);
1120         PL_last_lop = PL_last_uni = Nullch;
1121         SAVEFREESV(PL_linestr);
1122         PL_lex_dojoin = FALSE;
1123         PL_lex_brackets = 0;
1124         PL_lex_casemods = 0;
1125         *PL_lex_casestack = '\0';
1126         PL_lex_starts = 0;
1127         if (SvEVALED(PL_lex_repl)) {
1128             PL_lex_state = LEX_INTERPNORMAL;
1129             PL_lex_starts++;
1130             /*  we don't clear PL_lex_repl here, so that we can check later
1131                 whether this is an evalled subst; that means we rely on the
1132                 logic to ensure sublex_done() is called again only via the
1133                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
1134         }
1135         else {
1136             PL_lex_state = LEX_INTERPCONCAT;
1137             PL_lex_repl = Nullsv;
1138         }
1139         return ',';
1140     }
1141     else {
1142         LEAVE;
1143         PL_bufend = SvPVX(PL_linestr);
1144         PL_bufend += SvCUR(PL_linestr);
1145         PL_expect = XOPERATOR;
1146         PL_sublex_info.sub_inwhat = 0;
1147         return ')';
1148     }
1149 }
1150
1151 /*
1152   scan_const
1153
1154   Extracts a pattern, double-quoted string, or transliteration.  This
1155   is terrifying code.
1156
1157   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
1158   processing a pattern (PL_lex_inpat is true), a transliteration
1159   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
1160
1161   Returns a pointer to the character scanned up to. Iff this is
1162   advanced from the start pointer supplied (ie if anything was
1163   successfully parsed), will leave an OP for the substring scanned
1164   in yylval. Caller must intuit reason for not parsing further
1165   by looking at the next characters herself.
1166
1167   In patterns:
1168     backslashes:
1169       double-quoted style: \r and \n
1170       regexp special ones: \D \s
1171       constants: \x3
1172       backrefs: \1 (deprecated in substitution replacements)
1173       case and quoting: \U \Q \E
1174     stops on @ and $, but not for $ as tail anchor
1175
1176   In transliterations:
1177     characters are VERY literal, except for - not at the start or end
1178     of the string, which indicates a range.  scan_const expands the
1179     range to the full set of intermediate characters.
1180
1181   In double-quoted strings:
1182     backslashes:
1183       double-quoted style: \r and \n
1184       constants: \x3
1185       backrefs: \1 (deprecated)
1186       case and quoting: \U \Q \E
1187     stops on @ and $
1188
1189   scan_const does *not* construct ops to handle interpolated strings.
1190   It stops processing as soon as it finds an embedded $ or @ variable
1191   and leaves it to the caller to work out what's going on.
1192
1193   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo.
1194
1195   $ in pattern could be $foo or could be tail anchor.  Assumption:
1196   it's a tail anchor if $ is the last thing in the string, or if it's
1197   followed by one of ")| \n\t"
1198
1199   \1 (backreferences) are turned into $1
1200
1201   The structure of the code is
1202       while (there's a character to process) {
1203           handle transliteration ranges
1204           skip regexp comments
1205           skip # initiated comments in //x patterns
1206           check for embedded @foo
1207           check for embedded scalars
1208           if (backslash) {
1209               leave intact backslashes from leave (below)
1210               deprecate \1 in strings and sub replacements
1211               handle string-changing backslashes \l \U \Q \E, etc.
1212               switch (what was escaped) {
1213                   handle - in a transliteration (becomes a literal -)
1214                   handle \132 octal characters
1215                   handle 0x15 hex characters
1216                   handle \cV (control V)
1217                   handle printf backslashes (\f, \r, \n, etc)
1218               } (end switch)
1219           } (end if backslash)
1220     } (end while character to read)
1221
1222 */
1223
1224 STATIC char *
1225 S_scan_const(pTHX_ char *start)
1226 {
1227     register char *send = PL_bufend;            /* end of the constant */
1228     SV *sv = NEWSV(93, send - start);           /* sv for the constant */
1229     register char *s = start;                   /* start of the constant */
1230     register char *d = SvPVX(sv);               /* destination for copies */
1231     bool dorange = FALSE;                       /* are we in a translit range? */
1232     bool didrange = FALSE;                      /* did we just finish a range? */
1233     I32  has_utf8 = FALSE;                      /* Output constant is UTF8 */
1234     I32  this_utf8 = UTF;                       /* The source string is assumed to be UTF8 */
1235     UV uv;
1236
1237     const char *leaveit =       /* set of acceptably-backslashed characters */
1238         PL_lex_inpat
1239             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
1240             : "";
1241
1242     if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1243         /* If we are doing a trans and we know we want UTF8 set expectation */
1244         has_utf8   = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF);
1245         this_utf8  = PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1246     }
1247
1248
1249     while (s < send || dorange) {
1250         /* get transliterations out of the way (they're most literal) */
1251         if (PL_lex_inwhat == OP_TRANS) {
1252             /* expand a range A-Z to the full set of characters.  AIE! */
1253             if (dorange) {
1254                 I32 i;                          /* current expanded character */
1255                 I32 min;                        /* first character in range */
1256                 I32 max;                        /* last character in range */
1257
1258                 if (has_utf8) {
1259                     char *c = (char*)utf8_hop((U8*)d, -1);
1260                     char *e = d++;
1261                     while (e-- > c)
1262                         *(e + 1) = *e;
1263                     *c = (char)UTF_TO_NATIVE(0xff);
1264                     /* mark the range as done, and continue */
1265                     dorange = FALSE;
1266                     didrange = TRUE;
1267                     continue;
1268                 }
1269
1270                 i = d - SvPVX(sv);              /* remember current offset */
1271                 SvGROW(sv, SvLEN(sv) + 256);    /* never more than 256 chars in a range */
1272                 d = SvPVX(sv) + i;              /* refresh d after realloc */
1273                 d -= 2;                         /* eat the first char and the - */
1274
1275                 min = (U8)*d;                   /* first char in range */
1276                 max = (U8)d[1];                 /* last char in range  */
1277
1278                 if (min > max) {
1279                     Perl_croak(aTHX_
1280                                "Invalid range \"%c-%c\" in transliteration operator",
1281                                (char)min, (char)max);
1282                 }
1283
1284 #ifdef EBCDIC
1285                 if ((isLOWER(min) && isLOWER(max)) ||
1286                     (isUPPER(min) && isUPPER(max))) {
1287                     if (isLOWER(min)) {
1288                         for (i = min; i <= max; i++)
1289                             if (isLOWER(i))
1290                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1291                     } else {
1292                         for (i = min; i <= max; i++)
1293                             if (isUPPER(i))
1294                                 *d++ = NATIVE_TO_NEED(has_utf8,i);
1295                     }
1296                 }
1297                 else
1298 #endif
1299                     for (i = min; i <= max; i++)
1300                         *d++ = (char)i;
1301
1302                 /* mark the range as done, and continue */
1303                 dorange = FALSE;
1304                 didrange = TRUE;
1305                 continue;
1306             }
1307
1308             /* range begins (ignore - as first or last char) */
1309             else if (*s == '-' && s+1 < send  && s != start) {
1310                 if (didrange) {
1311                     Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
1312                 }
1313                 if (has_utf8) {
1314                     *d++ = (char)UTF_TO_NATIVE(0xff);   /* use illegal utf8 byte--see pmtrans */
1315                     s++;
1316                     continue;
1317                 }
1318                 dorange = TRUE;
1319                 s++;
1320             }
1321             else {
1322                 didrange = FALSE;
1323             }
1324         }
1325
1326         /* if we get here, we're not doing a transliteration */
1327
1328         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
1329            except for the last char, which will be done separately. */
1330         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
1331             if (s[2] == '#') {
1332                 while (s+1 < send && *s != ')')
1333                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1334             }
1335             else if (s[2] == '{' /* This should match regcomp.c */
1336                      || ((s[2] == 'p' || s[2] == '?') && s[3] == '{'))
1337             {
1338                 I32 count = 1;
1339                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1340                 char c;
1341
1342                 while (count && (c = *regparse)) {
1343                     if (c == '\\' && regparse[1])
1344                         regparse++;
1345                     else if (c == '{')
1346                         count++;
1347                     else if (c == '}')
1348                         count--;
1349                     regparse++;
1350                 }
1351                 if (*regparse != ')')
1352                     regparse--;         /* Leave one char for continuation. */
1353                 while (s < regparse)
1354                     *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1355             }
1356         }
1357
1358         /* likewise skip #-initiated comments in //x patterns */
1359         else if (*s == '#' && PL_lex_inpat &&
1360           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1361             while (s+1 < send && *s != '\n')
1362                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1363         }
1364
1365         /* check for embedded arrays
1366            (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-)
1367            */
1368         else if (*s == '@' && s[1]
1369                  && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1])))
1370             break;
1371
1372         /* check for embedded scalars.  only stop if we're sure it's a
1373            variable.
1374         */
1375         else if (*s == '$') {
1376             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1377                 break;
1378             if (s + 1 < send && !strchr("()| \r\n\t", s[1]))
1379                 break;          /* in regexp, $ might be tail anchor */
1380         }
1381
1382         /* End of else if chain - OP_TRANS rejoin rest */
1383
1384         /* backslashes */
1385         if (*s == '\\' && s+1 < send) {
1386             s++;
1387
1388             /* some backslashes we leave behind */
1389             if (*leaveit && *s && strchr(leaveit, *s)) {
1390                 *d++ = NATIVE_TO_NEED(has_utf8,'\\');
1391                 *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1392                 continue;
1393             }
1394
1395             /* deprecate \1 in strings and substitution replacements */
1396             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1397                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1398             {
1399                 if (ckWARN(WARN_SYNTAX))
1400                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\\%c better written as $%c", *s, *s);
1401                 *--s = '$';
1402                 break;
1403             }
1404
1405             /* string-change backslash escapes */
1406             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1407                 --s;
1408                 break;
1409             }
1410
1411             /* if we get here, it's either a quoted -, or a digit */
1412             switch (*s) {
1413
1414             /* quoted - in transliterations */
1415             case '-':
1416                 if (PL_lex_inwhat == OP_TRANS) {
1417                     *d++ = *s++;
1418                     continue;
1419                 }
1420                 /* FALL THROUGH */
1421             default:
1422                 {
1423                     if (ckWARN(WARN_MISC) &&
1424                         isALNUM(*s) &&
1425                         *s != '_')
1426                         Perl_warner(aTHX_ packWARN(WARN_MISC),
1427                                "Unrecognized escape \\%c passed through",
1428                                *s);
1429                     /* default action is to copy the quoted character */
1430                     goto default_action;
1431                 }
1432
1433             /* \132 indicates an octal constant */
1434             case '0': case '1': case '2': case '3':
1435             case '4': case '5': case '6': case '7':
1436                 {
1437                     I32 flags = 0;
1438                     STRLEN len = 3;
1439                     uv = grok_oct(s, &len, &flags, NULL);
1440                     s += len;
1441                 }
1442                 goto NUM_ESCAPE_INSERT;
1443
1444             /* \x24 indicates a hex constant */
1445             case 'x':
1446                 ++s;
1447                 if (*s == '{') {
1448                     char* e = strchr(s, '}');
1449                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1450                       PERL_SCAN_DISALLOW_PREFIX;
1451                     STRLEN len;
1452
1453                     ++s;
1454                     if (!e) {
1455                         yyerror("Missing right brace on \\x{}");
1456                         continue;
1457                     }
1458                     len = e - s;
1459                     uv = grok_hex(s, &len, &flags, NULL);
1460                     s = e + 1;
1461                 }
1462                 else {
1463                     {
1464                         STRLEN len = 2;
1465                         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
1466                         uv = grok_hex(s, &len, &flags, NULL);
1467                         s += len;
1468                     }
1469                 }
1470
1471               NUM_ESCAPE_INSERT:
1472                 /* Insert oct or hex escaped character.
1473                  * There will always enough room in sv since such
1474                  * escapes will be longer than any UTF-8 sequence
1475                  * they can end up as. */
1476
1477                 /* We need to map to chars to ASCII before doing the tests
1478                    to cover EBCDIC
1479                 */
1480                 if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(uv))) {
1481                     if (!has_utf8 && uv > 255) {
1482                         /* Might need to recode whatever we have
1483                          * accumulated so far if it contains any
1484                          * hibit chars.
1485                          *
1486                          * (Can't we keep track of that and avoid
1487                          *  this rescan? --jhi)
1488                          */
1489                         int hicount = 0;
1490                         U8 *c;
1491                         for (c = (U8 *) SvPVX(sv); c < (U8 *)d; c++) {
1492                             if (!NATIVE_IS_INVARIANT(*c)) {
1493                                 hicount++;
1494                             }
1495                         }
1496                         if (hicount) {
1497                             STRLEN offset = d - SvPVX(sv);
1498                             U8 *src, *dst;
1499                             d = SvGROW(sv, SvLEN(sv) + hicount + 1) + offset;
1500                             src = (U8 *)d - 1;
1501                             dst = src+hicount;
1502                             d  += hicount;
1503                             while (src >= (U8 *)SvPVX(sv)) {
1504                                 if (!NATIVE_IS_INVARIANT(*src)) {
1505                                     U8 ch = NATIVE_TO_ASCII(*src);
1506                                     *dst-- = (U8)UTF8_EIGHT_BIT_LO(ch);
1507                                     *dst-- = (U8)UTF8_EIGHT_BIT_HI(ch);
1508                                 }
1509                                 else {
1510                                     *dst-- = *src;
1511                                 }
1512                                 src--;
1513                             }
1514                         }
1515                     }
1516
1517                     if (has_utf8 || uv > 255) {
1518                         d = (char*)uvchr_to_utf8((U8*)d, uv);
1519                         has_utf8 = TRUE;
1520                         if (PL_lex_inwhat == OP_TRANS &&
1521                             PL_sublex_info.sub_op) {
1522                             PL_sublex_info.sub_op->op_private |=
1523                                 (PL_lex_repl ? OPpTRANS_FROM_UTF
1524                                              : OPpTRANS_TO_UTF);
1525                         }
1526                     }
1527                     else {
1528                         *d++ = (char)uv;
1529                     }
1530                 }
1531                 else {
1532                     *d++ = (char) uv;
1533                 }
1534                 continue;
1535
1536             /* \N{LATIN SMALL LETTER A} is a named character */
1537             case 'N':
1538                 ++s;
1539                 if (*s == '{') {
1540                     char* e = strchr(s, '}');
1541                     SV *res;
1542                     STRLEN len;
1543                     char *str;
1544
1545                     if (!e) {
1546                         yyerror("Missing right brace on \\N{}");
1547                         e = s - 1;
1548                         goto cont_scan;
1549                     }
1550                     if (e > s + 2 && s[1] == 'U' && s[2] == '+') {
1551                         /* \N{U+...} */
1552                         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES |
1553                           PERL_SCAN_DISALLOW_PREFIX;
1554                         s += 3;
1555                         len = e - s;
1556                         uv = grok_hex(s, &len, &flags, NULL);
1557                         s = e + 1;
1558                         goto NUM_ESCAPE_INSERT;
1559                     }
1560                     res = newSVpvn(s + 1, e - s - 1);
1561                     res = new_constant( Nullch, 0, "charnames",
1562                                         res, Nullsv, "\\N{...}" );
1563                     if (has_utf8)
1564                         sv_utf8_upgrade(res);
1565                     str = SvPV(res,len);
1566 #ifdef EBCDIC_NEVER_MIND
1567                     /* charnames uses pack U and that has been
1568                      * recently changed to do the below uni->native
1569                      * mapping, so this would be redundant (and wrong,
1570                      * the code point would be doubly converted).
1571                      * But leave this in just in case the pack U change
1572                      * gets revoked, but the semantics is still
1573                      * desireable for charnames. --jhi */
1574                     {
1575                          UV uv = utf8_to_uvchr((U8*)str, 0);
1576
1577                          if (uv < 0x100) {
1578                               U8 tmpbuf[UTF8_MAXLEN+1], *d;
1579
1580                               d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv));
1581                               sv_setpvn(res, (char *)tmpbuf, d - tmpbuf);
1582                               str = SvPV(res, len);
1583                          }
1584                     }
1585 #endif
1586                     if (!has_utf8 && SvUTF8(res)) {
1587                         char *ostart = SvPVX(sv);
1588                         SvCUR_set(sv, d - ostart);
1589                         SvPOK_on(sv);
1590                         *d = '\0';
1591                         sv_utf8_upgrade(sv);
1592                         /* this just broke our allocation above... */
1593                         SvGROW(sv, (STRLEN)(send - start));
1594                         d = SvPVX(sv) + SvCUR(sv);
1595                         has_utf8 = TRUE;
1596                     }
1597                     if (len > (STRLEN)(e - s + 4)) { /* I _guess_ 4 is \N{} --jhi */
1598                         char *odest = SvPVX(sv);
1599
1600                         SvGROW(sv, (SvLEN(sv) + len - (e - s + 4)));
1601                         d = SvPVX(sv) + (d - odest);
1602                     }
1603                     Copy(str, d, len, char);
1604                     d += len;
1605                     SvREFCNT_dec(res);
1606                   cont_scan:
1607                     s = e + 1;
1608                 }
1609                 else
1610                     yyerror("Missing braces on \\N{}");
1611                 continue;
1612
1613             /* \c is a control character */
1614             case 'c':
1615                 s++;
1616                 if (s < send) {
1617                     U8 c = *s++;
1618 #ifdef EBCDIC
1619                     if (isLOWER(c))
1620                         c = toUPPER(c);
1621 #endif
1622                     *d++ = NATIVE_TO_NEED(has_utf8,toCTRL(c));
1623                 }
1624                 else {
1625                     yyerror("Missing control char name in \\c");
1626                 }
1627                 continue;
1628
1629             /* printf-style backslashes, formfeeds, newlines, etc */
1630             case 'b':
1631                 *d++ = NATIVE_TO_NEED(has_utf8,'\b');
1632                 break;
1633             case 'n':
1634                 *d++ = NATIVE_TO_NEED(has_utf8,'\n');
1635                 break;
1636             case 'r':
1637                 *d++ = NATIVE_TO_NEED(has_utf8,'\r');
1638                 break;
1639             case 'f':
1640                 *d++ = NATIVE_TO_NEED(has_utf8,'\f');
1641                 break;
1642             case 't':
1643                 *d++ = NATIVE_TO_NEED(has_utf8,'\t');
1644                 break;
1645             case 'e':
1646                 *d++ = ASCII_TO_NEED(has_utf8,'\033');
1647                 break;
1648             case 'a':
1649                 *d++ = ASCII_TO_NEED(has_utf8,'\007');
1650                 break;
1651             } /* end switch */
1652
1653             s++;
1654             continue;
1655         } /* end if (backslash) */
1656
1657     default_action:
1658         /* If we started with encoded form, or already know we want it
1659            and then encode the next character */
1660         if ((has_utf8 || this_utf8) && !NATIVE_IS_INVARIANT((U8)(*s))) {
1661             STRLEN len  = 1;
1662             UV uv       = (this_utf8) ? utf8n_to_uvchr((U8*)s, send - s, &len, 0) : (UV) ((U8) *s);
1663             STRLEN need = UNISKIP(NATIVE_TO_UNI(uv));
1664             s += len;
1665             if (need > len) {
1666                 /* encoded value larger than old, need extra space (NOTE: SvCUR() not set here) */
1667                 STRLEN off = d - SvPVX(sv);
1668                 d = SvGROW(sv, SvLEN(sv) + (need-len)) + off;
1669             }
1670             d = (char*)uvchr_to_utf8((U8*)d, uv);
1671             has_utf8 = TRUE;
1672         }
1673         else {
1674             *d++ = NATIVE_TO_NEED(has_utf8,*s++);
1675         }
1676     } /* while loop to process each character */
1677
1678     /* terminate the string and set up the sv */
1679     *d = '\0';
1680     SvCUR_set(sv, d - SvPVX(sv));
1681     if (SvCUR(sv) >= SvLEN(sv))
1682         Perl_croak(aTHX_ "panic: constant overflowed allocated space");
1683
1684     SvPOK_on(sv);
1685     if (PL_encoding && !has_utf8) {
1686         sv_recode_to_utf8(sv, PL_encoding);
1687         if (SvUTF8(sv))
1688             has_utf8 = TRUE;
1689     }
1690     if (has_utf8) {
1691         SvUTF8_on(sv);
1692         if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) {
1693             PL_sublex_info.sub_op->op_private |=
1694                     (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF);
1695         }
1696     }
1697
1698     /* shrink the sv if we allocated more than we used */
1699     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1700         SvLEN_set(sv, SvCUR(sv) + 1);
1701         Renew(SvPVX(sv), SvLEN(sv), char);
1702     }
1703
1704     /* return the substring (via yylval) only if we parsed anything */
1705     if (s > PL_bufptr) {
1706         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1707             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1708                               sv, Nullsv,
1709                               ( PL_lex_inwhat == OP_TRANS
1710                                 ? "tr"
1711                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1712                                     ? "s"
1713                                     : "qq")));
1714         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1715     } else
1716         SvREFCNT_dec(sv);
1717     return s;
1718 }
1719
1720 /* S_intuit_more
1721  * Returns TRUE if there's more to the expression (e.g., a subscript),
1722  * FALSE otherwise.
1723  *
1724  * It deals with "$foo[3]" and /$foo[3]/ and /$foo[0123456789$]+/
1725  *
1726  * ->[ and ->{ return TRUE
1727  * { and [ outside a pattern are always subscripts, so return TRUE
1728  * if we're outside a pattern and it's not { or [, then return FALSE
1729  * if we're in a pattern and the first char is a {
1730  *   {4,5} (any digits around the comma) returns FALSE
1731  * if we're in a pattern and the first char is a [
1732  *   [] returns FALSE
1733  *   [SOMETHING] has a funky algorithm to decide whether it's a
1734  *      character class or not.  It has to deal with things like
1735  *      /$foo[-3]/ and /$foo[$bar]/ as well as /$foo[$\d]+/
1736  * anything else returns TRUE
1737  */
1738
1739 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1740
1741 STATIC int
1742 S_intuit_more(pTHX_ register char *s)
1743 {
1744     if (PL_lex_brackets)
1745         return TRUE;
1746     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1747         return TRUE;
1748     if (*s != '{' && *s != '[')
1749         return FALSE;
1750     if (!PL_lex_inpat)
1751         return TRUE;
1752
1753     /* In a pattern, so maybe we have {n,m}. */
1754     if (*s == '{') {
1755         s++;
1756         if (!isDIGIT(*s))
1757             return TRUE;
1758         while (isDIGIT(*s))
1759             s++;
1760         if (*s == ',')
1761             s++;
1762         while (isDIGIT(*s))
1763             s++;
1764         if (*s == '}')
1765             return FALSE;
1766         return TRUE;
1767
1768     }
1769
1770     /* On the other hand, maybe we have a character class */
1771
1772     s++;
1773     if (*s == ']' || *s == '^')
1774         return FALSE;
1775     else {
1776         /* this is terrifying, and it works */
1777         int weight = 2;         /* let's weigh the evidence */
1778         char seen[256];
1779         unsigned char un_char = 255, last_un_char;
1780         char *send = strchr(s,']');
1781         char tmpbuf[sizeof PL_tokenbuf * 4];
1782
1783         if (!send)              /* has to be an expression */
1784             return TRUE;
1785
1786         Zero(seen,256,char);
1787         if (*s == '$')
1788             weight -= 3;
1789         else if (isDIGIT(*s)) {
1790             if (s[1] != ']') {
1791                 if (isDIGIT(s[1]) && s[2] == ']')
1792                     weight -= 10;
1793             }
1794             else
1795                 weight -= 100;
1796         }
1797         for (; s < send; s++) {
1798             last_un_char = un_char;
1799             un_char = (unsigned char)*s;
1800             switch (*s) {
1801             case '@':
1802             case '&':
1803             case '$':
1804                 weight -= seen[un_char] * 10;
1805                 if (isALNUM_lazy_if(s+1,UTF)) {
1806                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1807                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1808                         weight -= 100;
1809                     else
1810                         weight -= 10;
1811                 }
1812                 else if (*s == '$' && s[1] &&
1813                   strchr("[#!%*<>()-=",s[1])) {
1814                     if (/*{*/ strchr("])} =",s[2]))
1815                         weight -= 10;
1816                     else
1817                         weight -= 1;
1818                 }
1819                 break;
1820             case '\\':
1821                 un_char = 254;
1822                 if (s[1]) {
1823                     if (strchr("wds]",s[1]))
1824                         weight += 100;
1825                     else if (seen['\''] || seen['"'])
1826                         weight += 1;
1827                     else if (strchr("rnftbxcav",s[1]))
1828                         weight += 40;
1829                     else if (isDIGIT(s[1])) {
1830                         weight += 40;
1831                         while (s[1] && isDIGIT(s[1]))
1832                             s++;
1833                     }
1834                 }
1835                 else
1836                     weight += 100;
1837                 break;
1838             case '-':
1839                 if (s[1] == '\\')
1840                     weight += 50;
1841                 if (strchr("aA01! ",last_un_char))
1842                     weight += 30;
1843                 if (strchr("zZ79~",s[1]))
1844                     weight += 30;
1845                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1846                     weight -= 5;        /* cope with negative subscript */
1847                 break;
1848             default:
1849                 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1850                         isALPHA(*s) && s[1] && isALPHA(s[1])) {
1851                     char *d = tmpbuf;
1852                     while (isALPHA(*s))
1853                         *d++ = *s++;
1854                     *d = '\0';
1855                     if (keyword(tmpbuf, d - tmpbuf))
1856                         weight -= 150;
1857                 }
1858                 if (un_char == last_un_char + 1)
1859                     weight += 5;
1860                 weight -= seen[un_char];
1861                 break;
1862             }
1863             seen[un_char]++;
1864         }
1865         if (weight >= 0)        /* probably a character class */
1866             return FALSE;
1867     }
1868
1869     return TRUE;
1870 }
1871
1872 /*
1873  * S_intuit_method
1874  *
1875  * Does all the checking to disambiguate
1876  *   foo bar
1877  * between foo(bar) and bar->foo.  Returns 0 if not a method, otherwise
1878  * FUNCMETH (bar->foo(args)) or METHOD (bar->foo args).
1879  *
1880  * First argument is the stuff after the first token, e.g. "bar".
1881  *
1882  * Not a method if bar is a filehandle.
1883  * Not a method if foo is a subroutine prototyped to take a filehandle.
1884  * Not a method if it's really "Foo $bar"
1885  * Method if it's "foo $bar"
1886  * Not a method if it's really "print foo $bar"
1887  * Method if it's really "foo package::" (interpreted as package->foo)
1888  * Not a method if bar is known to be a subroutine ("sub bar; foo bar")
1889  * Not a method if bar is a filehandle or package, but is quoted with
1890  *   =>
1891  */
1892
1893 STATIC int
1894 S_intuit_method(pTHX_ char *start, GV *gv)
1895 {
1896     char *s = start + (*start == '$');
1897     char tmpbuf[sizeof PL_tokenbuf];
1898     STRLEN len;
1899     GV* indirgv;
1900
1901     if (gv) {
1902         CV *cv;
1903         if (GvIO(gv))
1904             return 0;
1905         if ((cv = GvCVu(gv))) {
1906             char *proto = SvPVX(cv);
1907             if (proto) {
1908                 if (*proto == ';')
1909                     proto++;
1910                 if (*proto == '*')
1911                     return 0;
1912             }
1913         } else
1914             gv = 0;
1915     }
1916     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1917     /* start is the beginning of the possible filehandle/object,
1918      * and s is the end of it
1919      * tmpbuf is a copy of it
1920      */
1921
1922     if (*start == '$') {
1923         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1924             return 0;
1925         s = skipspace(s);
1926         PL_bufptr = start;
1927         PL_expect = XREF;
1928         return *s == '(' ? FUNCMETH : METHOD;
1929     }
1930     if (!keyword(tmpbuf, len)) {
1931         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1932             len -= 2;
1933             tmpbuf[len] = '\0';
1934             goto bare_package;
1935         }
1936         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1937         if (indirgv && GvCVu(indirgv))
1938             return 0;
1939         /* filehandle or package name makes it a method */
1940         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1941             s = skipspace(s);
1942             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1943                 return 0;       /* no assumptions -- "=>" quotes bearword */
1944       bare_package:
1945             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1946                                                    newSVpvn(tmpbuf,len));
1947             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1948             PL_expect = XTERM;
1949             force_next(WORD);
1950             PL_bufptr = s;
1951             return *s == '(' ? FUNCMETH : METHOD;
1952         }
1953     }
1954     return 0;
1955 }
1956
1957 /*
1958  * S_incl_perldb
1959  * Return a string of Perl code to load the debugger.  If PERL5DB
1960  * is set, it will return the contents of that, otherwise a
1961  * compile-time require of perl5db.pl.
1962  */
1963
1964 STATIC char*
1965 S_incl_perldb(pTHX)
1966 {
1967     if (PL_perldb) {
1968         char *pdb = PerlEnv_getenv("PERL5DB");
1969
1970         if (pdb)
1971             return pdb;
1972         SETERRNO(0,SS_NORMAL);
1973         return "BEGIN { require 'perl5db.pl' }";
1974     }
1975     return "";
1976 }
1977
1978
1979 /* Encoded script support. filter_add() effectively inserts a
1980  * 'pre-processing' function into the current source input stream.
1981  * Note that the filter function only applies to the current source file
1982  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1983  *
1984  * The datasv parameter (which may be NULL) can be used to pass
1985  * private data to this instance of the filter. The filter function
1986  * can recover the SV using the FILTER_DATA macro and use it to
1987  * store private buffers and state information.
1988  *
1989  * The supplied datasv parameter is upgraded to a PVIO type
1990  * and the IoDIRP/IoANY field is used to store the function pointer,
1991  * and IOf_FAKE_DIRP is enabled on datasv to mark this as such.
1992  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1993  * private use must be set using malloc'd pointers.
1994  */
1995
1996 SV *
1997 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1998 {
1999     if (!funcp)
2000         return Nullsv;
2001
2002     if (!PL_rsfp_filters)
2003         PL_rsfp_filters = newAV();
2004     if (!datasv)
2005         datasv = NEWSV(255,0);
2006     if (!SvUPGRADE(datasv, SVt_PVIO))
2007         Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
2008     IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */
2009     IoFLAGS(datasv) |= IOf_FAKE_DIRP;
2010     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n",
2011                           (void*)funcp, SvPV_nolen(datasv)));
2012     av_unshift(PL_rsfp_filters, 1);
2013     av_store(PL_rsfp_filters, 0, datasv) ;
2014     return(datasv);
2015 }
2016
2017
2018 /* Delete most recently added instance of this filter function. */
2019 void
2020 Perl_filter_del(pTHX_ filter_t funcp)
2021 {
2022     SV *datasv;
2023     DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp));
2024     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
2025         return;
2026     /* if filter is on top of stack (usual case) just pop it off */
2027     datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters));
2028     if (IoANY(datasv) == (void *)funcp) {
2029         IoFLAGS(datasv) &= ~IOf_FAKE_DIRP;
2030         IoANY(datasv) = (void *)NULL;
2031         sv_free(av_pop(PL_rsfp_filters));
2032
2033         return;
2034     }
2035     /* we need to search for the correct entry and clear it     */
2036     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
2037 }
2038
2039
2040 /* Invoke the n'th filter function for the current rsfp.         */
2041 I32
2042 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
2043
2044
2045                         /* 0 = read one text line */
2046 {
2047     filter_t funcp;
2048     SV *datasv = NULL;
2049
2050     if (!PL_rsfp_filters)
2051         return -1;
2052     if (idx > AvFILLp(PL_rsfp_filters)){       /* Any more filters?     */
2053         /* Provide a default input filter to make life easy.    */
2054         /* Note that we append to the line. This is handy.      */
2055         DEBUG_P(PerlIO_printf(Perl_debug_log,
2056                               "filter_read %d: from rsfp\n", idx));
2057         if (maxlen) {
2058             /* Want a block */
2059             int len ;
2060             int old_len = SvCUR(buf_sv) ;
2061
2062             /* ensure buf_sv is large enough */
2063             SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ;
2064             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
2065                 if (PerlIO_error(PL_rsfp))
2066                     return -1;          /* error */
2067                 else
2068                     return 0 ;          /* end of file */
2069             }
2070             SvCUR_set(buf_sv, old_len + len) ;
2071         } else {
2072             /* Want a line */
2073             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
2074                 if (PerlIO_error(PL_rsfp))
2075                     return -1;          /* error */
2076                 else
2077                     return 0 ;          /* end of file */
2078             }
2079         }
2080         return SvCUR(buf_sv);
2081     }
2082     /* Skip this filter slot if filter has been deleted */
2083     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
2084         DEBUG_P(PerlIO_printf(Perl_debug_log,
2085                               "filter_read %d: skipped (filter deleted)\n",
2086                               idx));
2087         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
2088     }
2089     /* Get function pointer hidden within datasv        */
2090     funcp = (filter_t)IoANY(datasv);
2091     DEBUG_P(PerlIO_printf(Perl_debug_log,
2092                           "filter_read %d: via function %p (%s)\n",
2093                           idx, (void*)funcp, SvPV_nolen(datasv)));
2094     /* Call function. The function is expected to       */
2095     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
2096     /* Return: <0:error, =0:eof, >0:not eof             */
2097     return (*funcp)(aTHX_ idx, buf_sv, maxlen);
2098 }
2099
2100 STATIC char *
2101 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
2102 {
2103 #ifdef PERL_CR_FILTER
2104     if (!PL_rsfp_filters) {
2105         filter_add(S_cr_textfilter,NULL);
2106     }
2107 #endif
2108     if (PL_rsfp_filters) {
2109
2110         if (!append)
2111             SvCUR_set(sv, 0);   /* start with empty line        */
2112         if (FILTER_READ(0, sv, 0) > 0)
2113             return ( SvPVX(sv) ) ;
2114         else
2115             return Nullch ;
2116     }
2117     else
2118         return (sv_gets(sv, fp, append));
2119 }
2120
2121 STATIC HV *
2122 S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
2123 {
2124     GV *gv;
2125
2126     if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
2127         return PL_curstash;
2128
2129     if (len > 2 &&
2130         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
2131         (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
2132     {
2133         return GvHV(gv);                        /* Foo:: */
2134     }
2135
2136     /* use constant CLASS => 'MyClass' */
2137     if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
2138         SV *sv;
2139         if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
2140             pkgname = SvPV_nolen(sv);
2141         }
2142     }
2143
2144     return gv_stashpv(pkgname, FALSE);
2145 }
2146
2147 #ifdef DEBUGGING
2148     static char* exp_name[] =
2149         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
2150           "ATTRTERM", "TERMBLOCK", "TERMORDORDOR"
2151         };
2152 #endif
2153
2154 /*
2155   yylex
2156
2157   Works out what to call the token just pulled out of the input
2158   stream.  The yacc parser takes care of taking the ops we return and
2159   stitching them into a tree.
2160
2161   Returns:
2162     PRIVATEREF
2163
2164   Structure:
2165       if read an identifier
2166           if we're in a my declaration
2167               croak if they tried to say my($foo::bar)
2168               build the ops for a my() declaration
2169           if it's an access to a my() variable
2170               are we in a sort block?
2171                   croak if my($a); $a <=> $b
2172               build ops for access to a my() variable
2173           if in a dq string, and they've said @foo and we can't find @foo
2174               croak
2175           build ops for a bareword
2176       if we already built the token before, use it.
2177 */
2178
2179 #ifdef USE_PURE_BISON
2180 int
2181 Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp)
2182 {
2183     int r;
2184
2185     yyactlevel++;
2186     yylval_pointer[yyactlevel] = lvalp;
2187     yychar_pointer[yyactlevel] = lcharp;
2188     if (yyactlevel >= YYMAXLEVEL)
2189         Perl_croak(aTHX_ "panic: YYMAXLEVEL");
2190
2191     r = Perl_yylex(aTHX);
2192
2193     if (yyactlevel > 0)
2194        yyactlevel--;
2195
2196     return r;
2197 }
2198 #endif
2199
2200 #ifdef __SC__
2201 #pragma segment Perl_yylex
2202 #endif
2203 int
2204 Perl_yylex(pTHX)
2205 {
2206     register char *s;
2207     register char *d;
2208     register I32 tmp;
2209     STRLEN len;
2210     GV *gv = Nullgv;
2211     GV **gvp = 0;
2212     bool bof = FALSE;
2213     I32 orig_keyword = 0;
2214
2215     /* check if there's an identifier for us to look at */
2216     if (PL_pending_ident)
2217         return S_pending_ident(aTHX);
2218
2219     /* no identifier pending identification */
2220
2221     switch (PL_lex_state) {
2222 #ifdef COMMENTARY
2223     case LEX_NORMAL:            /* Some compilers will produce faster */
2224     case LEX_INTERPNORMAL:      /* code if we comment these out. */
2225         break;
2226 #endif
2227
2228     /* when we've already built the next token, just pull it out of the queue */
2229     case LEX_KNOWNEXT:
2230         PL_nexttoke--;
2231         yylval = PL_nextval[PL_nexttoke];
2232         if (!PL_nexttoke) {
2233             PL_lex_state = PL_lex_defer;
2234             PL_expect = PL_lex_expect;
2235             PL_lex_defer = LEX_NORMAL;
2236         }
2237         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2238               "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
2239               (IV)PL_nexttype[PL_nexttoke]); });
2240
2241         return(PL_nexttype[PL_nexttoke]);
2242
2243     /* interpolated case modifiers like \L \U, including \Q and \E.
2244        when we get here, PL_bufptr is at the \
2245     */
2246     case LEX_INTERPCASEMOD:
2247 #ifdef DEBUGGING
2248         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
2249             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
2250 #endif
2251         /* handle \E or end of string */
2252         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
2253             char oldmod;
2254
2255             /* if at a \E */
2256             if (PL_lex_casemods) {
2257                 oldmod = PL_lex_casestack[--PL_lex_casemods];
2258                 PL_lex_casestack[PL_lex_casemods] = '\0';
2259
2260                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
2261                     PL_bufptr += 2;
2262                     PL_lex_state = LEX_INTERPCONCAT;
2263                 }
2264                 return ')';
2265             }
2266             if (PL_bufptr != PL_bufend)
2267                 PL_bufptr += 2;
2268             PL_lex_state = LEX_INTERPCONCAT;
2269             return yylex();
2270         }
2271         else {
2272             DEBUG_T({ PerlIO_printf(Perl_debug_log,
2273               "### Saw case modifier at '%s'\n", PL_bufptr); });
2274             s = PL_bufptr + 1;
2275             if (s[1] == '\\' && s[2] == 'E') {
2276                 PL_bufptr = s + 3;
2277                 PL_lex_state = LEX_INTERPCONCAT;
2278                 return yylex();
2279             }
2280             else {
2281                 if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
2282                     tmp = *s, *s = s[2], s[2] = (char)tmp;      /* misordered... */
2283                 if (strchr("LU", *s) &&
2284                     (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) {
2285                     PL_lex_casestack[--PL_lex_casemods] = '\0';
2286                     return ')';
2287                 }
2288                 if (PL_lex_casemods > 10)
2289                     Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
2290                 PL_lex_casestack[PL_lex_casemods++] = *s;
2291                 PL_lex_casestack[PL_lex_casemods] = '\0';
2292                 PL_lex_state = LEX_INTERPCONCAT;
2293                 PL_nextval[PL_nexttoke].ival = 0;
2294                 force_next('(');
2295                 if (*s == 'l')
2296                     PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
2297                 else if (*s == 'u')
2298                     PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
2299                 else if (*s == 'L')
2300                     PL_nextval[PL_nexttoke].ival = OP_LC;
2301                 else if (*s == 'U')
2302                     PL_nextval[PL_nexttoke].ival = OP_UC;
2303                 else if (*s == 'Q')
2304                     PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
2305                 else
2306                     Perl_croak(aTHX_ "panic: yylex");
2307                 PL_bufptr = s + 1;
2308             }
2309             force_next(FUNC);
2310             if (PL_lex_starts) {
2311                 s = PL_bufptr;
2312                 PL_lex_starts = 0;
2313                 Aop(OP_CONCAT);
2314             }
2315             else
2316                 return yylex();
2317         }
2318
2319     case LEX_INTERPPUSH:
2320         return sublex_push();
2321
2322     case LEX_INTERPSTART:
2323         if (PL_bufptr == PL_bufend)
2324             return sublex_done();
2325         DEBUG_T({ PerlIO_printf(Perl_debug_log,
2326               "### Interpolated variable at '%s'\n", PL_bufptr); });
2327         PL_expect = XTERM;
2328         PL_lex_dojoin = (*PL_bufptr == '@');
2329         PL_lex_state = LEX_INTERPNORMAL;
2330         if (PL_lex_dojoin) {
2331             PL_nextval[PL_nexttoke].ival = 0;
2332             force_next(',');
2333             force_ident("\"", '$');
2334             PL_nextval[PL_nexttoke].ival = 0;
2335             force_next('$');
2336             PL_nextval[PL_nexttoke].ival = 0;
2337             force_next('(');
2338             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
2339             force_next(FUNC);
2340         }
2341         if (PL_lex_starts++) {
2342             s = PL_bufptr;
2343             Aop(OP_CONCAT);
2344         }
2345         return yylex();
2346
2347     case LEX_INTERPENDMAYBE:
2348         if (intuit_more(PL_bufptr)) {
2349             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
2350             break;
2351         }
2352         /* FALL THROUGH */
2353
2354     case LEX_INTERPEND:
2355         if (PL_lex_dojoin) {
2356             PL_lex_dojoin = FALSE;
2357             PL_lex_state = LEX_INTERPCONCAT;
2358             return ')';
2359         }
2360         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
2361             && SvEVALED(PL_lex_repl))
2362         {
2363             if (PL_bufptr != PL_bufend)
2364                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
2365             PL_lex_repl = Nullsv;
2366         }
2367         /* FALLTHROUGH */
2368     case LEX_INTERPCONCAT:
2369 #ifdef DEBUGGING
2370         if (PL_lex_brackets)
2371             Perl_croak(aTHX_ "panic: INTERPCONCAT");
2372 #endif
2373         if (PL_bufptr == PL_bufend)
2374             return sublex_done();
2375
2376         if (SvIVX(PL_linestr) == '\'') {
2377             SV *sv = newSVsv(PL_linestr);
2378             if (!PL_lex_inpat)
2379                 sv = tokeq(sv);
2380             else if ( PL_hints & HINT_NEW_RE )
2381                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
2382             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
2383             s = PL_bufend;
2384         }
2385         else {
2386             s = scan_const(PL_bufptr);
2387             if (*s == '\\')
2388                 PL_lex_state = LEX_INTERPCASEMOD;
2389             else
2390                 PL_lex_state = LEX_INTERPSTART;
2391         }
2392
2393         if (s != PL_bufptr) {
2394             PL_nextval[PL_nexttoke] = yylval;
2395             PL_expect = XTERM;
2396             force_next(THING);
2397             if (PL_lex_starts++)
2398                 Aop(OP_CONCAT);
2399             else {
2400                 PL_bufptr = s;
2401                 return yylex();
2402             }
2403         }
2404
2405         return yylex();
2406     case LEX_FORMLINE:
2407         PL_lex_state = LEX_NORMAL;
2408         s = scan_formline(PL_bufptr);
2409         if (!PL_lex_formbrack)
2410             goto rightbracket;
2411         OPERATOR(';');
2412     }
2413
2414     s = PL_bufptr;
2415     PL_oldoldbufptr = PL_oldbufptr;
2416     PL_oldbufptr = s;
2417     DEBUG_T( {
2418         PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n",
2419                       exp_name[PL_expect], s);
2420     } );
2421
2422   retry:
2423     switch (*s) {
2424     default:
2425         if (isIDFIRST_lazy_if(s,UTF))
2426             goto keylookup;
2427         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
2428     case 4:
2429     case 26:
2430         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
2431     case 0:
2432         if (!PL_rsfp) {
2433             PL_last_uni = 0;
2434             PL_last_lop = 0;
2435             if (PL_lex_brackets) {
2436                 if (PL_lex_formbrack)
2437                     yyerror("Format not terminated");
2438                 else
2439                     yyerror("Missing right curly or square bracket");
2440             }
2441             DEBUG_T( { PerlIO_printf(Perl_debug_log,
2442                         "### Tokener got EOF\n");
2443             } );
2444             TOKEN(0);
2445         }
2446         if (s++ < PL_bufend)
2447             goto retry;                 /* ignore stray nulls */
2448         PL_last_uni = 0;
2449         PL_last_lop = 0;
2450         if (!PL_in_eval && !PL_preambled) {
2451             PL_preambled = TRUE;
2452             sv_setpv(PL_linestr,incl_perldb());
2453             if (SvCUR(PL_linestr))
2454                 sv_catpv(PL_linestr,";");
2455             if (PL_preambleav){
2456                 while(AvFILLp(PL_preambleav) >= 0) {
2457                     SV *tmpsv = av_shift(PL_preambleav);
2458                     sv_catsv(PL_linestr, tmpsv);
2459                     sv_catpv(PL_linestr, ";");
2460                     sv_free(tmpsv);
2461                 }
2462                 sv_free((SV*)PL_preambleav);
2463                 PL_preambleav = NULL;
2464             }
2465             if (PL_minus_n || PL_minus_p) {
2466                 sv_catpv(PL_linestr, "LINE: while (<>) {");
2467                 if (PL_minus_l)
2468                     sv_catpv(PL_linestr,"chomp;");
2469                 if (PL_minus_a) {
2470                     if (PL_minus_F) {
2471                         if (strchr("/'\"", *PL_splitstr)
2472                               && strchr(PL_splitstr + 1, *PL_splitstr))
2473                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr);
2474                         else {
2475                             char delim;
2476                             s = "'~#\200\1'"; /* surely one char is unused...*/
2477                             while (s[1] && strchr(PL_splitstr, *s))  s++;
2478                             delim = *s;
2479                             Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c",
2480                                       "q" + (delim == '\''), delim);
2481                             for (s = PL_splitstr; *s; s++) {
2482                                 if (*s == '\\')
2483                                     sv_catpvn(PL_linestr, "\\", 1);
2484                                 sv_catpvn(PL_linestr, s, 1);
2485                             }
2486                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
2487                         }
2488                     }
2489                     else
2490                         sv_catpv(PL_linestr,"our @F=split(' ');");
2491                 }
2492             }
2493             sv_catpv(PL_linestr, "\n");
2494             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2495             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2496             PL_last_lop = PL_last_uni = Nullch;
2497             if (PERLDB_LINE && PL_curstash != PL_debstash) {
2498                 SV *sv = NEWSV(85,0);
2499
2500                 sv_upgrade(sv, SVt_PVMG);
2501                 sv_setsv(sv,PL_linestr);
2502                 (void)SvIOK_on(sv);
2503                 SvIVX(sv) = 0;
2504                 av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2505             }
2506             goto retry;
2507         }
2508         do {
2509             bof = PL_rsfp ? TRUE : FALSE;
2510             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
2511               fake_eof:
2512                 if (PL_rsfp) {
2513                     if (PL_preprocess && !PL_in_eval)
2514                         (void)PerlProc_pclose(PL_rsfp);
2515                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2516                         PerlIO_clearerr(PL_rsfp);
2517                     else
2518                         (void)PerlIO_close(PL_rsfp);
2519                     PL_rsfp = Nullfp;
2520                     PL_doextract = FALSE;
2521                 }
2522                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2523                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2524                     sv_catpv(PL_linestr,";}");
2525                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2526                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2527                     PL_last_lop = PL_last_uni = Nullch;
2528                     PL_minus_n = PL_minus_p = 0;
2529                     goto retry;
2530                 }
2531                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2532                 PL_last_lop = PL_last_uni = Nullch;
2533                 sv_setpv(PL_linestr,"");
2534                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2535             }
2536             /* if it looks like the start of a BOM, check if it in fact is */
2537             else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) {
2538 #ifdef PERLIO_IS_STDIO
2539 #  ifdef __GNU_LIBRARY__
2540 #    if __GNU_LIBRARY__ == 1 /* Linux glibc5 */
2541 #      define FTELL_FOR_PIPE_IS_BROKEN
2542 #    endif
2543 #  else
2544 #    ifdef __GLIBC__
2545 #      if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */
2546 #        define FTELL_FOR_PIPE_IS_BROKEN
2547 #      endif
2548 #    endif
2549 #  endif
2550 #endif
2551 #ifdef FTELL_FOR_PIPE_IS_BROKEN
2552                 /* This loses the possibility to detect the bof
2553                  * situation on perl -P when the libc5 is being used.
2554                  * Workaround?  Maybe attach some extra state to PL_rsfp?
2555                  */
2556                 if (!PL_preprocess)
2557                     bof = PerlIO_tell(PL_rsfp) == SvCUR(PL_linestr);
2558 #else
2559                 bof = PerlIO_tell(PL_rsfp) == (Off_t)SvCUR(PL_linestr);
2560 #endif
2561                 if (bof) {
2562                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2563                     s = swallow_bom((U8*)s);
2564                 }
2565             }
2566             if (PL_doextract) {
2567                 /* Incest with pod. */
2568                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2569                     sv_setpv(PL_linestr, "");
2570                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2571                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2572                     PL_last_lop = PL_last_uni = Nullch;
2573                     PL_doextract = FALSE;
2574                 }
2575             }
2576             incline(s);
2577         } while (PL_doextract);
2578         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2579         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2580             SV *sv = NEWSV(85,0);
2581
2582             sv_upgrade(sv, SVt_PVMG);
2583             sv_setsv(sv,PL_linestr);
2584             (void)SvIOK_on(sv);
2585             SvIVX(sv) = 0;
2586             av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv);
2587         }
2588         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2589         PL_last_lop = PL_last_uni = Nullch;
2590         if (CopLINE(PL_curcop) == 1) {
2591             while (s < PL_bufend && isSPACE(*s))
2592                 s++;
2593             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2594                 s++;
2595             d = Nullch;
2596             if (!PL_in_eval) {
2597                 if (*s == '#' && *(s+1) == '!')
2598                     d = s + 2;
2599 #ifdef ALTERNATE_SHEBANG
2600                 else {
2601                     static char as[] = ALTERNATE_SHEBANG;
2602                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2603                         d = s + (sizeof(as) - 1);
2604                 }
2605 #endif /* ALTERNATE_SHEBANG */
2606             }
2607             if (d) {
2608                 char *ipath;
2609                 char *ipathend;
2610
2611                 while (isSPACE(*d))
2612                     d++;
2613                 ipath = d;
2614                 while (*d && !isSPACE(*d))
2615                     d++;
2616                 ipathend = d;
2617
2618 #ifdef ARG_ZERO_IS_SCRIPT
2619                 if (ipathend > ipath) {
2620                     /*
2621                      * HP-UX (at least) sets argv[0] to the script name,
2622                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2623                      * at least, set argv[0] to the basename of the Perl
2624                      * interpreter. So, having found "#!", we'll set it right.
2625                      */
2626                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
2627                     assert(SvPOK(x) || SvGMAGICAL(x));
2628                     if (sv_eq(x, CopFILESV(PL_curcop))) {
2629                         sv_setpvn(x, ipath, ipathend - ipath);
2630                         SvSETMAGIC(x);
2631                     }
2632                     else {
2633                         STRLEN blen;
2634                         STRLEN llen;
2635                         char *bstart = SvPV(CopFILESV(PL_curcop),blen);
2636                         char *lstart = SvPV(x,llen);
2637                         if (llen < blen) {
2638                             bstart += blen - llen;
2639                             if (strnEQ(bstart, lstart, llen) && bstart[-1] == '/') {
2640                                 sv_setpvn(x, ipath, ipathend - ipath);
2641                                 SvSETMAGIC(x);
2642                             }
2643                         }
2644                     }
2645                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2646                 }
2647 #endif /* ARG_ZERO_IS_SCRIPT */
2648
2649                 /*
2650                  * Look for options.
2651                  */
2652                 d = instr(s,"perl -");
2653                 if (!d) {
2654                     d = instr(s,"perl");
2655 #if defined(DOSISH)
2656                     /* avoid getting into infinite loops when shebang
2657                      * line contains "Perl" rather than "perl" */
2658                     if (!d) {
2659                         for (d = ipathend-4; d >= ipath; --d) {
2660                             if ((*d == 'p' || *d == 'P')
2661                                 && !ibcmp(d, "perl", 4))
2662                             {
2663                                 break;
2664                             }
2665                         }
2666                         if (d < ipath)
2667                             d = Nullch;
2668                     }
2669 #endif
2670                 }
2671 #ifdef ALTERNATE_SHEBANG
2672                 /*
2673                  * If the ALTERNATE_SHEBANG on this system starts with a
2674                  * character that can be part of a Perl expression, then if
2675                  * we see it but not "perl", we're probably looking at the
2676                  * start of Perl code, not a request to hand off to some
2677                  * other interpreter.  Similarly, if "perl" is there, but
2678                  * not in the first 'word' of the line, we assume the line
2679                  * contains the start of the Perl program.
2680                  */
2681                 if (d && *s != '#') {
2682                     char *c = ipath;
2683                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2684                         c++;
2685                     if (c < d)
2686                         d = Nullch;     /* "perl" not in first word; ignore */
2687                     else
2688                         *s = '#';       /* Don't try to parse shebang line */
2689                 }
2690 #endif /* ALTERNATE_SHEBANG */
2691 #ifndef MACOS_TRADITIONAL
2692                 if (!d &&
2693                     *s == '#' &&
2694                     ipathend > ipath &&
2695                     !PL_minus_c &&
2696                     !instr(s,"indir") &&
2697                     instr(PL_origargv[0],"perl"))
2698                 {
2699                     char **newargv;
2700
2701                     *ipathend = '\0';
2702                     s = ipathend + 1;
2703                     while (s < PL_bufend && isSPACE(*s))
2704                         s++;
2705                     if (s < PL_bufend) {
2706                         Newz(899,newargv,PL_origargc+3,char*);
2707                         newargv[1] = s;
2708                         while (s < PL_bufend && !isSPACE(*s))
2709                             s++;
2710                         *s = '\0';
2711                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2712                     }
2713                     else
2714                         newargv = PL_origargv;
2715                     newargv[0] = ipath;
2716                     PERL_FPU_PRE_EXEC
2717                     PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv));
2718                     PERL_FPU_POST_EXEC
2719                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2720                 }
2721 #endif
2722                 if (d) {
2723                     U32 oldpdb = PL_perldb;
2724                     bool oldn = PL_minus_n;
2725                     bool oldp = PL_minus_p;
2726
2727                     while (*d && !isSPACE(*d)) d++;
2728                     while (SPACE_OR_TAB(*d)) d++;
2729
2730                     if (*d++ == '-') {
2731                         bool switches_done = PL_doswitches;
2732                         do {
2733                             if (*d == 'M' || *d == 'm') {
2734                                 char *m = d;
2735                                 while (*d && !isSPACE(*d)) d++;
2736                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2737                                       (int)(d - m), m);
2738                             }
2739                             d = moreswitches(d);
2740                         } while (d);
2741                         if (PL_doswitches && !switches_done) {
2742                             int argc = PL_origargc;
2743                             char **argv = PL_origargv;
2744                             do {
2745                                 argc--,argv++;
2746                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2747                             init_argv_symbols(argc,argv);
2748                         }
2749                         if ((PERLDB_LINE && !oldpdb) ||
2750                             ((PL_minus_n || PL_minus_p) && !(oldn || oldp)))
2751                               /* if we have already added "LINE: while (<>) {",
2752                                  we must not do it again */
2753                         {
2754                             sv_setpv(PL_linestr, "");
2755                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2756                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2757                             PL_last_lop = PL_last_uni = Nullch;
2758                             PL_preambled = FALSE;
2759                             if (PERLDB_LINE)
2760                                 (void)gv_fetchfile(PL_origfilename);
2761                             goto retry;
2762                         }
2763                         if (PL_doswitches && !switches_done) {
2764                             int argc = PL_origargc;
2765                             char **argv = PL_origargv;
2766                             do {
2767                                 argc--,argv++;
2768                             } while (argc && argv[0][0] == '-' && argv[0][1]);
2769                             init_argv_symbols(argc,argv);
2770                         }
2771                     }
2772                 }
2773             }
2774         }
2775         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2776             PL_bufptr = s;
2777             PL_lex_state = LEX_FORMLINE;
2778             return yylex();
2779         }
2780         goto retry;
2781     case '\r':
2782 #ifdef PERL_STRICT_CR
2783         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2784         Perl_croak(aTHX_
2785       "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
2786 #endif
2787     case ' ': case '\t': case '\f': case 013:
2788 #ifdef MACOS_TRADITIONAL
2789     case '\312':
2790 #endif
2791         s++;
2792         goto retry;
2793     case '#':
2794     case '\n':
2795         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2796             if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
2797                 /* handle eval qq[#line 1 "foo"\n ...] */
2798                 CopLINE_dec(PL_curcop);
2799                 incline(s);
2800             }
2801             d = PL_bufend;
2802             while (s < d && *s != '\n')
2803                 s++;
2804             if (s < d)
2805                 s++;
2806             else if (s > d) /* Found by Ilya: feed random input to Perl. */
2807               Perl_croak(aTHX_ "panic: input overflow");
2808             incline(s);
2809             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2810                 PL_bufptr = s;
2811                 PL_lex_state = LEX_FORMLINE;
2812                 return yylex();
2813             }
2814         }
2815         else {
2816             *s = '\0';
2817             PL_bufend = s;
2818         }
2819         goto retry;
2820     case '-':
2821         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2822             I32 ftst = 0;
2823
2824             s++;
2825             PL_bufptr = s;
2826             tmp = *s++;
2827
2828             while (s < PL_bufend && SPACE_OR_TAB(*s))
2829                 s++;
2830
2831             if (strnEQ(s,"=>",2)) {
2832                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2833                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2834                             "### Saw unary minus before =>, forcing word '%s'\n", s);
2835                 } );
2836                 OPERATOR('-');          /* unary minus */
2837             }
2838             PL_last_uni = PL_oldbufptr;
2839             switch (tmp) {
2840             case 'r': ftst = OP_FTEREAD;        break;
2841             case 'w': ftst = OP_FTEWRITE;       break;
2842             case 'x': ftst = OP_FTEEXEC;        break;
2843             case 'o': ftst = OP_FTEOWNED;       break;
2844             case 'R': ftst = OP_FTRREAD;        break;
2845             case 'W': ftst = OP_FTRWRITE;       break;
2846             case 'X': ftst = OP_FTREXEC;        break;
2847             case 'O': ftst = OP_FTROWNED;       break;
2848             case 'e': ftst = OP_FTIS;           break;
2849             case 'z': ftst = OP_FTZERO;         break;
2850             case 's': ftst = OP_FTSIZE;         break;
2851             case 'f': ftst = OP_FTFILE;         break;
2852             case 'd': ftst = OP_FTDIR;          break;
2853             case 'l': ftst = OP_FTLINK;         break;
2854             case 'p': ftst = OP_FTPIPE;         break;
2855             case 'S': ftst = OP_FTSOCK;         break;
2856             case 'u': ftst = OP_FTSUID;         break;
2857             case 'g': ftst = OP_FTSGID;         break;
2858             case 'k': ftst = OP_FTSVTX;         break;
2859             case 'b': ftst = OP_FTBLK;          break;
2860             case 'c': ftst = OP_FTCHR;          break;
2861             case 't': ftst = OP_FTTTY;          break;
2862             case 'T': ftst = OP_FTTEXT;         break;
2863             case 'B': ftst = OP_FTBINARY;       break;
2864             case 'M': case 'A': case 'C':
2865                 gv_fetchpv("\024",TRUE, SVt_PV);
2866                 switch (tmp) {
2867                 case 'M': ftst = OP_FTMTIME;    break;
2868                 case 'A': ftst = OP_FTATIME;    break;
2869                 case 'C': ftst = OP_FTCTIME;    break;
2870                 default:                        break;
2871                 }
2872                 break;
2873             default:
2874                 break;
2875             }
2876             if (ftst) {
2877                 PL_last_lop_op = (OPCODE)ftst;
2878                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2879                         "### Saw file test %c\n", (int)ftst);
2880                 } );
2881                 FTST(ftst);
2882             }
2883             else {
2884                 /* Assume it was a minus followed by a one-letter named
2885                  * subroutine call (or a -bareword), then. */
2886                 DEBUG_T( { PerlIO_printf(Perl_debug_log,
2887                         "### '-%c' looked like a file test but was not\n",
2888                         tmp);
2889                 } );
2890                 s = --PL_bufptr;
2891             }
2892         }
2893         tmp = *s++;
2894         if (*s == tmp) {
2895             s++;
2896             if (PL_expect == XOPERATOR)
2897                 TERM(POSTDEC);
2898             else
2899                 OPERATOR(PREDEC);
2900         }
2901         else if (*s == '>') {
2902             s++;
2903             s = skipspace(s);
2904             if (isIDFIRST_lazy_if(s,UTF)) {
2905                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2906                 TOKEN(ARROW);
2907             }
2908             else if (*s == '$')
2909                 OPERATOR(ARROW);
2910             else
2911                 TERM(ARROW);
2912         }
2913         if (PL_expect == XOPERATOR)
2914             Aop(OP_SUBTRACT);
2915         else {
2916             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2917                 check_uni();
2918             OPERATOR('-');              /* unary minus */
2919         }
2920
2921     case '+':
2922         tmp = *s++;
2923         if (*s == tmp) {
2924             s++;
2925             if (PL_expect == XOPERATOR)
2926                 TERM(POSTINC);
2927             else
2928                 OPERATOR(PREINC);
2929         }
2930         if (PL_expect == XOPERATOR)
2931             Aop(OP_ADD);
2932         else {
2933             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2934                 check_uni();
2935             OPERATOR('+');
2936         }
2937
2938     case '*':
2939         if (PL_expect != XOPERATOR) {
2940             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2941             PL_expect = XOPERATOR;
2942             force_ident(PL_tokenbuf, '*');
2943             if (!*PL_tokenbuf)
2944                 PREREF('*');
2945             TERM('*');
2946         }
2947         s++;
2948         if (*s == '*') {
2949             s++;
2950             PWop(OP_POW);
2951         }
2952         Mop(OP_MULTIPLY);
2953
2954     case '%':
2955         if (PL_expect == XOPERATOR) {
2956             ++s;
2957             Mop(OP_MODULO);
2958         }
2959         PL_tokenbuf[0] = '%';
2960         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2961         if (!PL_tokenbuf[1]) {
2962             PREREF('%');
2963         }
2964         PL_pending_ident = '%';
2965         TERM('%');
2966
2967     case '^':
2968         s++;
2969         BOop(OP_BIT_XOR);
2970     case '[':
2971         PL_lex_brackets++;
2972         /* FALL THROUGH */
2973     case '~':
2974     case ',':
2975         tmp = *s++;
2976         OPERATOR(tmp);
2977     case ':':
2978         if (s[1] == ':') {
2979             len = 0;
2980             goto just_a_word;
2981         }
2982         s++;
2983         switch (PL_expect) {
2984             OP *attrs;
2985         case XOPERATOR:
2986             if (!PL_in_my || PL_lex_state != LEX_NORMAL)
2987                 break;
2988             PL_bufptr = s;      /* update in case we back off */
2989             goto grabattrs;
2990         case XATTRBLOCK:
2991             PL_expect = XBLOCK;
2992             goto grabattrs;
2993         case XATTRTERM:
2994             PL_expect = XTERMBLOCK;
2995          grabattrs:
2996             s = skipspace(s);
2997             attrs = Nullop;
2998             while (isIDFIRST_lazy_if(s,UTF)) {
2999                 d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3000                 if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) {
3001                     if (tmp < 0) tmp = -tmp;
3002                     switch (tmp) {
3003                     case KEY_or:
3004                     case KEY_and:
3005                     case KEY_err:
3006                     case KEY_for:
3007                     case KEY_unless:
3008                     case KEY_if:
3009                     case KEY_while:
3010                     case KEY_until:
3011                         goto got_attrs;
3012                     default:
3013                         break;
3014                     }
3015                 }
3016                 if (*d == '(') {
3017                     d = scan_str(d,TRUE,TRUE);
3018                     if (!d) {
3019                         /* MUST advance bufptr here to avoid bogus
3020                            "at end of line" context messages from yyerror().
3021                          */
3022                         PL_bufptr = s + len;
3023                         yyerror("Unterminated attribute parameter in attribute list");
3024                         if (attrs)
3025                             op_free(attrs);
3026                         return 0;       /* EOF indicator */
3027                     }
3028                 }
3029                 if (PL_lex_stuff) {
3030                     SV *sv = newSVpvn(s, len);
3031                     sv_catsv(sv, PL_lex_stuff);
3032                     attrs = append_elem(OP_LIST, attrs,
3033                                         newSVOP(OP_CONST, 0, sv));
3034                     SvREFCNT_dec(PL_lex_stuff);
3035                     PL_lex_stuff = Nullsv;
3036                 }
3037                 else {
3038                     /* NOTE: any CV attrs applied here need to be part of
3039                        the CVf_BUILTIN_ATTRS define in cv.h! */
3040                     if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len))
3041                         CvLVALUE_on(PL_compcv);
3042                     else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len))
3043                         CvLOCKED_on(PL_compcv);
3044                     else if (!PL_in_my && len == 6 && strnEQ(s, "method", len))
3045                         CvMETHOD_on(PL_compcv);
3046                     else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len))
3047                         CvASSERTION_on(PL_compcv);
3048                     else if (PL_in_my == KEY_our && len == 6 &&
3049                              strnEQ(s, "unique", len))
3050 #ifdef USE_ITHREADS
3051                         GvUNIQUE_on(cGVOPx_gv(yylval.opval));
3052 #else
3053                         ; /* skip that case to avoid loading attributes.pm */
3054 #endif
3055                     /* After we've set the flags, it could be argued that
3056                        we don't need to do the attributes.pm-based setting
3057                        process, and shouldn't bother appending recognized
3058                        flags.  To experiment with that, uncomment the
3059                        following "else".  (Note that's already been
3060                        uncommented.  That keeps the above-applied built-in
3061                        attributes from being intercepted (and possibly
3062                        rejected) by a package's attribute routines, but is
3063                        justified by the performance win for the common case
3064                        of applying only built-in attributes.) */
3065                     else
3066                         attrs = append_elem(OP_LIST, attrs,
3067                                             newSVOP(OP_CONST, 0,
3068                                                     newSVpvn(s, len)));
3069                 }
3070                 s = skipspace(d);
3071                 if (*s == ':' && s[1] != ':')
3072                     s = skipspace(s+1);
3073                 else if (s == d)
3074                     break;      /* require real whitespace or :'s */
3075             }
3076             tmp = (PL_expect == XOPERATOR ? '=' : '{'); /*'}(' for vi */
3077             if (*s != ';' && *s != '}' && *s != tmp && (tmp != '=' || *s != ')')) {
3078                 char q = ((*s == '\'') ? '"' : '\'');
3079                 /* If here for an expression, and parsed no attrs, back off. */
3080                 if (tmp == '=' && !attrs) {
3081                     s = PL_bufptr;
3082                     break;
3083                 }
3084                 /* MUST advance bufptr here to avoid bogus "at end of line"
3085                    context messages from yyerror().
3086                  */
3087                 PL_bufptr = s;
3088                 if (!*s)
3089                     yyerror("Unterminated attribute list");
3090                 else
3091                     yyerror(Perl_form(aTHX_ "Invalid separator character %c%c%c in attribute list",
3092                                       q, *s, q));
3093                 if (attrs)
3094                     op_free(attrs);
3095                 OPERATOR(':');
3096             }
3097         got_attrs:
3098             if (attrs) {
3099                 PL_nextval[PL_nexttoke].opval = attrs;
3100                 force_next(THING);
3101             }
3102             TOKEN(COLONATTR);
3103         }
3104         OPERATOR(':');
3105     case '(':
3106         s++;
3107         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
3108             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
3109         else
3110             PL_expect = XTERM;
3111         s = skipspace(s);
3112         TOKEN('(');
3113     case ';':
3114         CLINE;
3115         tmp = *s++;
3116         OPERATOR(tmp);
3117     case ')':
3118         tmp = *s++;
3119         s = skipspace(s);
3120         if (*s == '{')
3121             PREBLOCK(tmp);
3122         TERM(tmp);
3123     case ']':
3124         s++;
3125         if (PL_lex_brackets <= 0)
3126             yyerror("Unmatched right square bracket");
3127         else
3128             --PL_lex_brackets;
3129         if (PL_lex_state == LEX_INTERPNORMAL) {
3130             if (PL_lex_brackets == 0) {
3131                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
3132                     PL_lex_state = LEX_INTERPEND;
3133             }
3134         }
3135         TERM(']');
3136     case '{':
3137       leftbracket:
3138         s++;
3139         if (PL_lex_brackets > 100) {
3140             Renew(PL_lex_brackstack, PL_lex_brackets + 10, char);
3141         }
3142         switch (PL_expect) {
3143         case XTERM:
3144             if (PL_lex_formbrack) {
3145                 s--;
3146                 PRETERMBLOCK(DO);
3147             }
3148             if (PL_oldoldbufptr == PL_last_lop)
3149                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3150             else
3151                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3152             OPERATOR(HASHBRACK);
3153         case XOPERATOR:
3154             while (s < PL_bufend && SPACE_OR_TAB(*s))
3155                 s++;
3156             d = s;
3157             PL_tokenbuf[0] = '\0';
3158             if (d < PL_bufend && *d == '-') {
3159                 PL_tokenbuf[0] = '-';
3160                 d++;
3161                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3162                     d++;
3163             }
3164             if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) {
3165                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
3166                               FALSE, &len);
3167                 while (d < PL_bufend && SPACE_OR_TAB(*d))
3168                     d++;
3169                 if (*d == '}') {
3170                     char minus = (PL_tokenbuf[0] == '-');
3171                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
3172                     if (minus)
3173                         force_next('-');
3174                 }
3175             }
3176             /* FALL THROUGH */
3177         case XATTRBLOCK:
3178         case XBLOCK:
3179             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
3180             PL_expect = XSTATE;
3181             break;
3182         case XATTRTERM:
3183         case XTERMBLOCK:
3184             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3185             PL_expect = XSTATE;
3186             break;
3187         default: {
3188                 char *t;
3189                 if (PL_oldoldbufptr == PL_last_lop)
3190                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
3191                 else
3192                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
3193                 s = skipspace(s);
3194                 if (*s == '}') {
3195                     if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) {
3196                         PL_expect = XTERM;
3197                         /* This hack is to get the ${} in the message. */
3198                         PL_bufptr = s+1;
3199                         yyerror("syntax error");
3200                         break;
3201                     }
3202                     OPERATOR(HASHBRACK);
3203                 }
3204                 /* This hack serves to disambiguate a pair of curlies
3205                  * as being a block or an anon hash.  Normally, expectation
3206                  * determines that, but in cases where we're not in a
3207                  * position to expect anything in particular (like inside
3208                  * eval"") we have to resolve the ambiguity.  This code
3209                  * covers the case where the first term in the curlies is a
3210                  * quoted string.  Most other cases need to be explicitly
3211                  * disambiguated by prepending a `+' before the opening
3212                  * curly in order to force resolution as an anon hash.
3213                  *
3214                  * XXX should probably propagate the outer expectation
3215                  * into eval"" to rely less on this hack, but that could
3216                  * potentially break current behavior of eval"".
3217                  * GSAR 97-07-21
3218                  */
3219                 t = s;
3220                 if (*s == '\'' || *s == '"' || *s == '`') {
3221                     /* common case: get past first string, handling escapes */
3222                     for (t++; t < PL_bufend && *t != *s;)
3223                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
3224                             t++;
3225                     t++;
3226                 }
3227                 else if (*s == 'q') {
3228                     if (++t < PL_bufend
3229                         && (!isALNUM(*t)
3230                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
3231                                 && !isALNUM(*t))))
3232                     {
3233                         /* skip q//-like construct */
3234                         char *tmps;
3235                         char open, close, term;
3236                         I32 brackets = 1;
3237
3238                         while (t < PL_bufend && isSPACE(*t))
3239                             t++;
3240                         /* check for q => */
3241                         if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') {
3242                             OPERATOR(HASHBRACK);
3243                         }
3244                         term = *t;
3245                         open = term;
3246                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
3247                             term = tmps[5];
3248                         close = term;
3249                         if (open == close)
3250                             for (t++; t < PL_bufend; t++) {
3251                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
3252                                     t++;
3253                                 else if (*t == open)
3254                                     break;
3255                             }
3256                         else {
3257                             for (t++; t < PL_bufend; t++) {
3258                                 if (*t == '\\' && t+1 < PL_bufend)
3259                                     t++;
3260                                 else if (*t == close && --brackets <= 0)
3261                                     break;
3262                                 else if (*t == open)
3263                                     brackets++;
3264                             }
3265                         }
3266                         t++;
3267                     }
3268                     else
3269                         /* skip plain q word */
3270                         while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3271                              t += UTF8SKIP(t);
3272                 }
3273                 else if (isALNUM_lazy_if(t,UTF)) {
3274                     t += UTF8SKIP(t);
3275                     while (t < PL_bufend && isALNUM_lazy_if(t,UTF))
3276                          t += UTF8SKIP(t);
3277                 }
3278                 while (t < PL_bufend && isSPACE(*t))
3279                     t++;
3280                 /* if comma follows first term, call it an anon hash */
3281                 /* XXX it could be a comma expression with loop modifiers */
3282                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
3283                                    || (*t == '=' && t[1] == '>')))
3284                     OPERATOR(HASHBRACK);
3285                 if (PL_expect == XREF)
3286                     PL_expect = XTERM;
3287                 else {
3288                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
3289                     PL_expect = XSTATE;
3290                 }
3291             }
3292             break;
3293         }
3294         yylval.ival = CopLINE(PL_curcop);
3295         if (isSPACE(*s) || *s == '#')
3296             PL_copline = NOLINE;   /* invalidate current command line number */
3297         TOKEN('{');
3298     case '}':
3299       rightbracket:
3300         s++;
3301         if (PL_lex_brackets <= 0)
3302             yyerror("Unmatched right curly bracket");
3303         else
3304             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
3305         if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL)
3306             PL_lex_formbrack = 0;
3307         if (PL_lex_state == LEX_INTERPNORMAL) {
3308             if (PL_lex_brackets == 0) {
3309                 if (PL_expect & XFAKEBRACK) {
3310                     PL_expect &= XENUMMASK;
3311                     PL_lex_state = LEX_INTERPEND;
3312                     PL_bufptr = s;
3313                     return yylex();     /* ignore fake brackets */
3314                 }
3315                 if (*s == '-' && s[1] == '>')
3316                     PL_lex_state = LEX_INTERPENDMAYBE;
3317                 else if (*s != '[' && *s != '{')
3318                     PL_lex_state = LEX_INTERPEND;
3319             }
3320         }
3321         if (PL_expect & XFAKEBRACK) {
3322             PL_expect &= XENUMMASK;
3323             PL_bufptr = s;
3324             return yylex();             /* ignore fake brackets */
3325         }
3326         force_next('}');
3327         TOKEN(';');
3328     case '&':
3329         s++;
3330         tmp = *s++;
3331         if (tmp == '&')
3332             AOPERATOR(ANDAND);
3333         s--;
3334         if (PL_expect == XOPERATOR) {
3335             if (ckWARN(WARN_SEMICOLON)
3336                 && isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
3337             {
3338                 CopLINE_dec(PL_curcop);
3339                 Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3340                 CopLINE_inc(PL_curcop);
3341             }
3342             BAop(OP_BIT_AND);
3343         }
3344
3345         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
3346         if (*PL_tokenbuf) {
3347             PL_expect = XOPERATOR;
3348             force_ident(PL_tokenbuf, '&');
3349         }
3350         else
3351             PREREF('&');
3352         yylval.ival = (OPpENTERSUB_AMPER<<8);
3353         TERM('&');
3354
3355     case '|':
3356         s++;
3357         tmp = *s++;
3358         if (tmp == '|')
3359             AOPERATOR(OROR);
3360         s--;
3361         BOop(OP_BIT_OR);
3362     case '=':
3363         s++;
3364         tmp = *s++;
3365         if (tmp == '=')
3366             Eop(OP_EQ);
3367         if (tmp == '>')
3368             OPERATOR(',');
3369         if (tmp == '~')
3370             PMop(OP_MATCH);
3371         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
3372             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
3373         s--;
3374         if (PL_expect == XSTATE && isALPHA(tmp) &&
3375                 (s == PL_linestart+1 || s[-2] == '\n') )
3376         {
3377             if (PL_in_eval && !PL_rsfp) {
3378                 d = PL_bufend;
3379                 while (s < d) {
3380                     if (*s++ == '\n') {
3381                         incline(s);
3382                         if (strnEQ(s,"=cut",4)) {
3383                             s = strchr(s,'\n');
3384                             if (s)
3385                                 s++;
3386                             else
3387                                 s = d;
3388                             incline(s);
3389                             goto retry;
3390                         }
3391                     }
3392                 }
3393                 goto retry;
3394             }
3395             s = PL_bufend;
3396             PL_doextract = TRUE;
3397             goto retry;
3398         }
3399         if (PL_lex_brackets < PL_lex_formbrack) {
3400             char *t;
3401 #ifdef PERL_STRICT_CR
3402             for (t = s; SPACE_OR_TAB(*t); t++) ;
3403 #else
3404             for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
3405 #endif
3406             if (*t == '\n' || *t == '#') {
3407                 s--;
3408                 PL_expect = XBLOCK;
3409                 goto leftbracket;
3410             }
3411         }
3412         yylval.ival = 0;
3413         OPERATOR(ASSIGNOP);
3414     case '!':
3415         s++;
3416         tmp = *s++;
3417         if (tmp == '=')
3418             Eop(OP_NE);
3419         if (tmp == '~')
3420             PMop(OP_NOT);
3421         s--;
3422         OPERATOR('!');
3423     case '<':
3424         if (PL_expect != XOPERATOR) {
3425             if (s[1] != '<' && !strchr(s,'>'))
3426                 check_uni();
3427             if (s[1] == '<')
3428                 s = scan_heredoc(s);
3429             else
3430                 s = scan_inputsymbol(s);
3431             TERM(sublex_start());
3432         }
3433         s++;
3434         tmp = *s++;
3435         if (tmp == '<')
3436             SHop(OP_LEFT_SHIFT);
3437         if (tmp == '=') {
3438             tmp = *s++;
3439             if (tmp == '>')
3440                 Eop(OP_NCMP);
3441             s--;
3442             Rop(OP_LE);
3443         }
3444         s--;
3445         Rop(OP_LT);
3446     case '>':
3447         s++;
3448         tmp = *s++;
3449         if (tmp == '>')
3450             SHop(OP_RIGHT_SHIFT);
3451         if (tmp == '=')
3452             Rop(OP_GE);
3453         s--;
3454         Rop(OP_GT);
3455
3456     case '$':
3457         CLINE;
3458
3459         if (PL_expect == XOPERATOR) {
3460             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3461                 PL_expect = XTERM;
3462                 depcom();
3463                 return ','; /* grandfather non-comma-format format */
3464             }
3465         }
3466
3467         if (s[1] == '#' && (isIDFIRST_lazy_if(s+2,UTF) || strchr("{$:+-", s[2]))) {
3468             PL_tokenbuf[0] = '@';
3469             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1,
3470                            sizeof PL_tokenbuf - 1, FALSE);
3471             if (PL_expect == XOPERATOR)
3472                 no_op("Array length", s);
3473             if (!PL_tokenbuf[1])
3474                 PREREF(DOLSHARP);
3475             PL_expect = XOPERATOR;
3476             PL_pending_ident = '#';
3477             TOKEN(DOLSHARP);
3478         }
3479
3480         PL_tokenbuf[0] = '$';
3481         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1,
3482                        sizeof PL_tokenbuf - 1, FALSE);
3483         if (PL_expect == XOPERATOR)
3484             no_op("Scalar", s);
3485         if (!PL_tokenbuf[1]) {
3486             if (s == PL_bufend)
3487                 yyerror("Final $ should be \\$ or $name");
3488             PREREF('$');
3489         }
3490
3491         /* This kludge not intended to be bulletproof. */
3492         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
3493             yylval.opval = newSVOP(OP_CONST, 0,
3494                                    newSViv(PL_compiling.cop_arybase));
3495             yylval.opval->op_private = OPpCONST_ARYBASE;
3496             TERM(THING);
3497         }
3498
3499         d = s;
3500         tmp = (I32)*s;
3501         if (PL_lex_state == LEX_NORMAL)
3502             s = skipspace(s);
3503
3504         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3505             char *t;
3506             if (*s == '[') {
3507                 PL_tokenbuf[0] = '@';
3508                 if (ckWARN(WARN_SYNTAX)) {
3509                     for(t = s + 1;
3510                         isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$';
3511                         t++) ;
3512                     if (*t++ == ',') {
3513                         PL_bufptr = skipspace(PL_bufptr);
3514                         while (t < PL_bufend && *t != ']')
3515                             t++;
3516                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3517                                 "Multidimensional syntax %.*s not supported",
3518                                 (t - PL_bufptr) + 1, PL_bufptr);
3519                     }
3520                 }
3521             }
3522             else if (*s == '{') {
3523                 PL_tokenbuf[0] = '%';
3524                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
3525                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
3526                 {
3527                     char tmpbuf[sizeof PL_tokenbuf];
3528                     STRLEN len;
3529                     for (t++; isSPACE(*t); t++) ;
3530                     if (isIDFIRST_lazy_if(t,UTF)) {
3531                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
3532                         for (; isSPACE(*t); t++) ;
3533                         if (*t == ';' && get_cv(tmpbuf, FALSE))
3534                             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3535                                 "You need to quote \"%s\"", tmpbuf);
3536                     }
3537                 }
3538             }
3539         }
3540
3541         PL_expect = XOPERATOR;
3542         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
3543             bool islop = (PL_last_lop == PL_oldoldbufptr);
3544             if (!islop || PL_last_lop_op == OP_GREPSTART)
3545                 PL_expect = XOPERATOR;
3546             else if (strchr("$@\"'`q", *s))
3547                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
3548             else if (strchr("&*<%", *s) && isIDFIRST_lazy_if(s+1,UTF))
3549                 PL_expect = XTERM;              /* e.g. print $fh &sub */
3550             else if (isIDFIRST_lazy_if(s,UTF)) {
3551                 char tmpbuf[sizeof PL_tokenbuf];
3552                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3553                 if ((tmp = keyword(tmpbuf, len))) {
3554                     /* binary operators exclude handle interpretations */
3555                     switch (tmp) {
3556                     case -KEY_x:
3557                     case -KEY_eq:
3558                     case -KEY_ne:
3559                     case -KEY_gt:
3560                     case -KEY_lt:
3561                     case -KEY_ge:
3562                     case -KEY_le:
3563                     case -KEY_cmp:
3564                         break;
3565                     default:
3566                         PL_expect = XTERM;      /* e.g. print $fh length() */
3567                         break;
3568                     }
3569                 }
3570                 else {
3571                     PL_expect = XTERM;          /* e.g. print $fh subr() */
3572                 }
3573             }
3574             else if (isDIGIT(*s))
3575                 PL_expect = XTERM;              /* e.g. print $fh 3 */
3576             else if (*s == '.' && isDIGIT(s[1]))
3577                 PL_expect = XTERM;              /* e.g. print $fh .3 */
3578             else if (strchr("?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
3579                 PL_expect = XTERM;              /* e.g. print $fh -1 */
3580             else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/')
3581                 PL_expect = XTERM;              /* e.g. print $fh /.../
3582                                                  XXX except DORDOR operator */
3583             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
3584                 PL_expect = XTERM;              /* print $fh <<"EOF" */
3585         }
3586         PL_pending_ident = '$';
3587         TOKEN('$');
3588
3589     case '@':
3590         if (PL_expect == XOPERATOR)
3591             no_op("Array", s);
3592         PL_tokenbuf[0] = '@';
3593         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
3594         if (!PL_tokenbuf[1]) {
3595             PREREF('@');
3596         }
3597         if (PL_lex_state == LEX_NORMAL)
3598             s = skipspace(s);
3599         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
3600             if (*s == '{')
3601                 PL_tokenbuf[0] = '%';
3602
3603             /* Warn about @ where they meant $. */
3604             if (ckWARN(WARN_SYNTAX)) {
3605                 if (*s == '[' || *s == '{') {
3606                     char *t = s + 1;
3607                     while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
3608                         t++;
3609                     if (*t == '}' || *t == ']') {
3610                         t++;
3611                         PL_bufptr = skipspace(PL_bufptr);
3612                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
3613                             "Scalar value %.*s better written as $%.*s",
3614                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
3615                     }
3616                 }
3617             }
3618         }
3619         PL_pending_ident = '@';
3620         TERM('@');
3621
3622      case '/':                  /* may be division, defined-or, or pattern */
3623         if (PL_expect == XTERMORDORDOR && s[1] == '/') {
3624             s += 2;
3625             AOPERATOR(DORDOR);
3626         }
3627      case '?':                  /* may either be conditional or pattern */
3628          if(PL_expect == XOPERATOR) {
3629              tmp = *s++;
3630              if(tmp == '?') {
3631                   OPERATOR('?');
3632              }
3633              else {
3634                  tmp = *s++;
3635                  if(tmp == '/') {
3636                      /* A // operator. */
3637                     AOPERATOR(DORDOR);
3638                  }
3639                  else {
3640                      s--;
3641                      Mop(OP_DIVIDE);
3642                  }
3643              }
3644          }
3645          else {
3646              /* Disable warning on "study /blah/" */
3647              if (PL_oldoldbufptr == PL_last_uni
3648               && (*PL_last_uni != 's' || s - PL_last_uni < 5
3649                   || memNE(PL_last_uni, "study", 5)
3650                   || isALNUM_lazy_if(PL_last_uni+5,UTF)
3651               ))
3652                  check_uni();
3653              s = scan_pat(s,OP_MATCH);
3654              TERM(sublex_start());
3655          }
3656
3657     case '.':
3658         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
3659 #ifdef PERL_STRICT_CR
3660             && s[1] == '\n'
3661 #else
3662             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
3663 #endif
3664             && (s == PL_linestart || s[-1] == '\n') )
3665         {
3666             PL_lex_formbrack = 0;
3667             PL_expect = XSTATE;
3668             goto rightbracket;
3669         }
3670         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
3671             tmp = *s++;
3672             if (*s == tmp) {
3673                 s++;
3674                 if (*s == tmp) {
3675                     s++;
3676                     yylval.ival = OPf_SPECIAL;
3677                 }
3678                 else
3679                     yylval.ival = 0;
3680                 OPERATOR(DOTDOT);
3681             }
3682             if (PL_expect != XOPERATOR)
3683                 check_uni();
3684             Aop(OP_CONCAT);
3685         }
3686         /* FALL THROUGH */
3687     case '0': case '1': case '2': case '3': case '4':
3688     case '5': case '6': case '7': case '8': case '9':
3689         s = scan_num(s, &yylval);
3690         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3691                     "### Saw number in '%s'\n", s);
3692         } );
3693         if (PL_expect == XOPERATOR)
3694             no_op("Number",s);
3695         TERM(THING);
3696
3697     case '\'':
3698         s = scan_str(s,FALSE,FALSE);
3699         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3700                     "### Saw string before '%s'\n", s);
3701         } );
3702         if (PL_expect == XOPERATOR) {
3703             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3704                 PL_expect = XTERM;
3705                 depcom();
3706                 return ',';     /* grandfather non-comma-format format */
3707             }
3708             else
3709                 no_op("String",s);
3710         }
3711         if (!s)
3712             missingterm((char*)0);
3713         yylval.ival = OP_CONST;
3714         TERM(sublex_start());
3715
3716     case '"':
3717         s = scan_str(s,FALSE,FALSE);
3718         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3719                     "### Saw string before '%s'\n", s);
3720         } );
3721         if (PL_expect == XOPERATOR) {
3722             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
3723                 PL_expect = XTERM;
3724                 depcom();
3725                 return ',';     /* grandfather non-comma-format format */
3726             }
3727             else
3728                 no_op("String",s);
3729         }
3730         if (!s)
3731             missingterm((char*)0);
3732         yylval.ival = OP_CONST;
3733         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
3734             if (*d == '$' || *d == '@' || *d == '\\' || !UTF8_IS_INVARIANT((U8)*d)) {
3735                 yylval.ival = OP_STRINGIFY;
3736                 break;
3737             }
3738         }
3739         TERM(sublex_start());
3740
3741     case '`':
3742         s = scan_str(s,FALSE,FALSE);
3743         DEBUG_T( { PerlIO_printf(Perl_debug_log,
3744                     "### Saw backtick string before '%s'\n", s);
3745         } );
3746         if (PL_expect == XOPERATOR)
3747             no_op("Backticks",s);
3748         if (!s)
3749             missingterm((char*)0);
3750         yylval.ival = OP_BACKTICK;
3751         set_csh();
3752         TERM(sublex_start());
3753
3754     case '\\':
3755         s++;
3756         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
3757             Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
3758                         *s, *s);
3759         if (PL_expect == XOPERATOR)
3760             no_op("Backslash",s);
3761         OPERATOR(REFGEN);
3762
3763     case 'v':
3764         if (isDIGIT(s[1]) && PL_expect != XOPERATOR) {
3765             char *start = s;
3766             start++;
3767             start++;
3768             while (isDIGIT(*start) || *start == '_')
3769                 start++;
3770             if (*start == '.' && isDIGIT(start[1])) {
3771                 s = scan_num(s, &yylval);
3772                 TERM(THING);
3773             }
3774             /* avoid v123abc() or $h{v1}, allow C<print v10;> */
3775             else if (!isALPHA(*start) && (PL_expect == XTERM
3776                         || PL_expect == XREF || PL_expect == XSTATE
3777                         || PL_expect == XTERMORDORDOR)) {
3778                 char c = *start;
3779                 GV *gv;
3780                 *start = '\0';
3781                 gv = gv_fetchpv(s, FALSE, SVt_PVCV);
3782                 *start = c;
3783                 if (!gv) {
3784                     s = scan_num(s, &yylval);
3785                     TERM(THING);
3786                 }
3787             }
3788         }
3789         goto keylookup;
3790     case 'x':
3791         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
3792             s++;
3793             Mop(OP_REPEAT);
3794         }
3795         goto keylookup;
3796
3797     case '_':
3798     case 'a': case 'A':
3799     case 'b': case 'B':
3800     case 'c': case 'C':
3801     case 'd': case 'D':
3802     case 'e': case 'E':
3803     case 'f': case 'F':
3804     case 'g': case 'G':
3805     case 'h': case 'H':
3806     case 'i': case 'I':
3807     case 'j': case 'J':
3808     case 'k': case 'K':
3809     case 'l': case 'L':
3810     case 'm': case 'M':
3811     case 'n': case 'N':
3812     case 'o': case 'O':
3813     case 'p': case 'P':
3814     case 'q': case 'Q':
3815     case 'r': case 'R':
3816     case 's': case 'S':
3817     case 't': case 'T':
3818     case 'u': case 'U':
3819               case 'V':
3820     case 'w': case 'W':
3821               case 'X':
3822     case 'y': case 'Y':
3823     case 'z': case 'Z':
3824
3825       keylookup: {
3826         orig_keyword = 0;
3827         gv = Nullgv;
3828         gvp = 0;
3829
3830         PL_bufptr = s;
3831         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3832
3833         /* Some keywords can be followed by any delimiter, including ':' */
3834         tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) ||
3835                (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3836                              (PL_tokenbuf[0] == 'q' &&
3837                               strchr("qwxr", PL_tokenbuf[1])))));
3838
3839         /* x::* is just a word, unless x is "CORE" */
3840         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3841             goto just_a_word;
3842
3843         d = s;
3844         while (d < PL_bufend && isSPACE(*d))
3845                 d++;    /* no comments skipped here, or s### is misparsed */
3846
3847         /* Is this a label? */
3848         if (!tmp && PL_expect == XSTATE
3849               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3850             s = d + 1;
3851             yylval.pval = savepv(PL_tokenbuf);
3852             CLINE;
3853             TOKEN(LABEL);
3854         }
3855
3856         /* Check for keywords */
3857         tmp = keyword(PL_tokenbuf, len);
3858
3859         /* Is this a word before a => operator? */
3860         if (*d == '=' && d[1] == '>') {
3861             CLINE;
3862             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3863             yylval.opval->op_private = OPpCONST_BARE;
3864             if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
3865               SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
3866             TERM(WORD);
3867         }
3868
3869         if (tmp < 0) {                  /* second-class keyword? */
3870             GV *ogv = Nullgv;   /* override (winner) */
3871             GV *hgv = Nullgv;   /* hidden (loser) */
3872             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3873                 CV *cv;
3874                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3875                     (cv = GvCVu(gv)))
3876                 {
3877                     if (GvIMPORTED_CV(gv))
3878                         ogv = gv;
3879                     else if (! CvMETHOD(cv))
3880                         hgv = gv;
3881                 }
3882                 if (!ogv &&
3883                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3884                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3885                     GvCVu(gv) && GvIMPORTED_CV(gv))
3886                 {
3887                     ogv = gv;
3888                 }
3889             }
3890             if (ogv) {
3891                 orig_keyword = tmp;
3892                 tmp = 0;                /* overridden by import or by GLOBAL */
3893             }
3894             else if (gv && !gvp
3895                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3896                      && GvCVu(gv)
3897                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3898             {
3899                 tmp = 0;                /* any sub overrides "weak" keyword */
3900             }
3901             else {                      /* no override */
3902                 tmp = -tmp;
3903                 if (tmp == KEY_dump && ckWARN(WARN_MISC)) {
3904                     Perl_warner(aTHX_ packWARN(WARN_MISC),
3905                             "dump() better written as CORE::dump()");
3906                 }
3907                 gv = Nullgv;
3908                 gvp = 0;
3909                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3910                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3911                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
3912                         "Ambiguous call resolved as CORE::%s(), %s",
3913                          GvENAME(hgv), "qualify as such or use &");
3914             }
3915         }
3916
3917       reserved_word:
3918         switch (tmp) {
3919
3920         default:                        /* not a keyword */
3921           just_a_word: {
3922                 SV *sv;
3923                 int pkgname = 0;
3924                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3925
3926                 /* Get the rest if it looks like a package qualifier */
3927
3928                 if (*s == '\'' || (*s == ':' && s[1] == ':')) {
3929                     STRLEN morelen;
3930                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3931                                   TRUE, &morelen);
3932                     if (!morelen)
3933                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3934                                 *s == '\'' ? "'" : "::");
3935                     len += morelen;
3936                     pkgname = 1;
3937                 }
3938
3939                 if (PL_expect == XOPERATOR) {
3940                     if (PL_bufptr == PL_linestart) {
3941                         CopLINE_dec(PL_curcop);
3942                         Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
3943                         CopLINE_inc(PL_curcop);
3944                     }
3945                     else
3946                         no_op("Bareword",s);
3947                 }
3948
3949                 /* Look for a subroutine with this name in current package,
3950                    unless name is "Foo::", in which case Foo is a bearword
3951                    (and a package name). */
3952
3953                 if (len > 2 &&
3954                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3955                 {
3956                     if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3957                         Perl_warner(aTHX_ packWARN(WARN_BAREWORD),
3958                             "Bareword \"%s\" refers to nonexistent package",
3959                              PL_tokenbuf);
3960                     len -= 2;
3961                     PL_tokenbuf[len] = '\0';
3962                     gv = Nullgv;
3963                     gvp = 0;
3964                 }
3965                 else {
3966                     len = 0;
3967                     if (!gv)
3968                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3969                 }
3970
3971                 /* if we saw a global override before, get the right name */
3972
3973                 if (gvp) {
3974                     sv = newSVpvn("CORE::GLOBAL::",14);
3975                     sv_catpv(sv,PL_tokenbuf);
3976                 }
3977                 else
3978                     sv = newSVpv(PL_tokenbuf,0);
3979
3980                 /* Presume this is going to be a bareword of some sort. */
3981
3982                 CLINE;
3983                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3984                 yylval.opval->op_private = OPpCONST_BARE;
3985                 /* UTF-8 package name? */
3986                 if (UTF && !IN_BYTES &&
3987                     is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
3988                     SvUTF8_on(sv);
3989
3990                 /* And if "Foo::", then that's what it certainly is. */
3991
3992                 if (len)
3993                     goto safe_bareword;
3994
3995                 /* See if it's the indirect object for a list operator. */
3996
3997                 if (PL_oldoldbufptr &&
3998                     PL_oldoldbufptr < PL_bufptr &&
3999                     (PL_oldoldbufptr == PL_last_lop
4000                      || PL_oldoldbufptr == PL_last_uni) &&
4001                     /* NO SKIPSPACE BEFORE HERE! */
4002                     (PL_expect == XREF ||
4003                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
4004                 {
4005                     bool immediate_paren = *s == '(';
4006
4007                     /* (Now we can afford to cross potential line boundary.) */
4008                     s = skipspace(s);
4009
4010                     /* Two barewords in a row may indicate method call. */
4011
4012                     if ((isIDFIRST_lazy_if(s,UTF) || *s == '$') && (tmp=intuit_method(s,gv)))
4013                         return tmp;
4014
4015                     /* If not a declared subroutine, it's an indirect object. */
4016                     /* (But it's an indir obj regardless for sort.) */
4017
4018                     if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
4019                          ((!gv || !GvCVu(gv)) &&
4020                         (PL_last_lop_op != OP_MAPSTART &&
4021                          PL_last_lop_op != OP_GREPSTART))))
4022                     {
4023                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
4024                         goto bareword;
4025                     }
4026                 }
4027
4028                 PL_expect = XOPERATOR;
4029                 s = skipspace(s);
4030
4031                 /* Is this a word before a => operator? */
4032                 if (*s == '=' && s[1] == '>' && !pkgname) {
4033                     CLINE;
4034                     sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
4035                     if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len))
4036                       SvUTF8_on(((SVOP*)yylval.opval)->op_sv);
4037                     TERM(WORD);
4038                 }
4039
4040                 /* If followed by a paren, it's certainly a subroutine. */
4041                 if (*s == '(') {
4042                     CLINE;
4043                     if (gv && GvCVu(gv)) {
4044                         for (d = s + 1; SPACE_OR_TAB(*d); d++) ;
4045                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
4046                             s = d + 1;
4047                             goto its_constant;
4048                         }
4049                     }
4050                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4051                     PL_expect = XOPERATOR;
4052                     force_next(WORD);
4053                     yylval.ival = 0;
4054                     TOKEN('&');
4055                 }
4056
4057                 /* If followed by var or block, call it a method (unless sub) */
4058
4059                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
4060                     PL_last_lop = PL_oldbufptr;
4061                     PL_last_lop_op = OP_METHOD;
4062                     PREBLOCK(METHOD);
4063                 }
4064
4065                 /* If followed by a bareword, see if it looks like indir obj. */
4066
4067                 if (!orig_keyword
4068                         && (isIDFIRST_lazy_if(s,UTF) || *s == '$')
4069                         && (tmp = intuit_method(s,gv)))
4070                     return tmp;
4071
4072                 /* Not a method, so call it a subroutine (if defined) */
4073
4074                 if (gv && GvCVu(gv)) {
4075                     CV* cv;
4076                     if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS))
4077                         Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4078                                 "Ambiguous use of -%s resolved as -&%s()",
4079                                 PL_tokenbuf, PL_tokenbuf);
4080                     /* Check for a constant sub */
4081                     cv = GvCV(gv);
4082                     if ((sv = cv_const_sv(cv))) {
4083                   its_constant:
4084                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
4085                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
4086                         yylval.opval->op_private = 0;
4087                         TOKEN(WORD);
4088                     }
4089
4090                     /* Resolve to GV now. */
4091                     op_free(yylval.opval);
4092                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
4093                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
4094                     PL_last_lop = PL_oldbufptr;
4095                     PL_last_lop_op = OP_ENTERSUB;
4096                     /* Is there a prototype? */
4097                     if (SvPOK(cv)) {
4098                         STRLEN len;
4099                         char *proto = SvPV((SV*)cv, len);
4100                         if (!len)
4101                             TERM(FUNC0SUB);
4102                         if (strEQ(proto, "$"))
4103                             OPERATOR(UNIOPSUB);
4104                         while (*proto == ';')
4105                             proto++;
4106                         if (*proto == '&' && *s == '{') {
4107                             sv_setpv(PL_subname, PL_curstash ?
4108                                         "__ANON__" : "__ANON__::__ANON__");
4109                             PREBLOCK(LSTOPSUB);
4110                         }
4111                     }
4112                     PL_nextval[PL_nexttoke].opval = yylval.opval;
4113                     PL_expect = XTERM;
4114                     force_next(WORD);
4115                     TOKEN(NOAMP);
4116                 }
4117
4118                 /* Call it a bare word */
4119
4120                 if (PL_hints & HINT_STRICT_SUBS)
4121                     yylval.opval->op_private |= OPpCONST_STRICT;
4122                 else {
4123                 bareword:
4124                     if (ckWARN(WARN_RESERVED)) {
4125                         if (lastchar != '-') {
4126                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
4127                             if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
4128                                 Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
4129                                        PL_tokenbuf);
4130                         }
4131                     }
4132                 }
4133
4134             safe_bareword:
4135                 if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) {
4136                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4137                         "Operator or semicolon missing before %c%s",
4138                         lastchar, PL_tokenbuf);
4139                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
4140                         "Ambiguous use of %c resolved as operator %c",
4141                         lastchar, lastchar);
4142                 }
4143                 TOKEN(WORD);
4144             }
4145
4146         case KEY___FILE__:
4147             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4148                                         newSVpv(CopFILE(PL_curcop),0));
4149             TERM(THING);
4150
4151         case KEY___LINE__:
4152             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4153                                     Perl_newSVpvf(aTHX_ "%"IVdf, (IV)CopLINE(PL_curcop)));
4154             TERM(THING);
4155
4156         case KEY___PACKAGE__:
4157             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
4158                                         (PL_curstash
4159                                          ? newSVsv(PL_curstname)
4160                                          : &PL_sv_undef));
4161             TERM(THING);
4162
4163         case KEY___DATA__:
4164         case KEY___END__: {
4165             GV *gv;
4166
4167             /*SUPPRESS 560*/
4168             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
4169                 char *pname = "main";
4170                 if (PL_tokenbuf[2] == 'D')
4171                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
4172                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
4173                 GvMULTI_on(gv);
4174                 if (!GvIO(gv))
4175                     GvIOp(gv) = newIO();
4176                 IoIFP(GvIOp(gv)) = PL_rsfp;
4177 #if defined(HAS_FCNTL) && defined(F_SETFD)
4178                 {
4179                     int fd = PerlIO_fileno(PL_rsfp);
4180                     fcntl(fd,F_SETFD,fd >= 3);
4181                 }
4182 #endif
4183                 /* Mark this internal pseudo-handle as clean */
4184                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
4185                 if (PL_preprocess)
4186                     IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
4187                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
4188                     IoTYPE(GvIOp(gv)) = IoTYPE_STD;
4189                 else
4190                     IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
4191 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
4192                 /* if the script was opened in binmode, we need to revert
4193                  * it to text mode for compatibility; but only iff it has CRs
4194                  * XXX this is a questionable hack at best. */
4195                 if (PL_bufend-PL_bufptr > 2
4196                     && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
4197                 {
4198                     Off_t loc = 0;
4199                     if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
4200                         loc = PerlIO_tell(PL_rsfp);
4201                         (void)PerlIO_seek(PL_rsfp, 0L, 0);
4202                     }
4203 #ifdef NETWARE
4204                         if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) {
4205 #else
4206                     if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) {
4207 #endif  /* NETWARE */
4208 #ifdef PERLIO_IS_STDIO /* really? */
4209 #  if defined(__BORLANDC__)
4210                         /* XXX see note in do_binmode() */
4211                         ((FILE*)PL_rsfp)->flags &= ~_F_BIN;
4212 #  endif
4213 #endif
4214                         if (loc > 0)
4215                             PerlIO_seek(PL_rsfp, loc, 0);
4216                     }
4217                 }
4218 #endif
4219 #ifdef PERLIO_LAYERS
4220                 if (!IN_BYTES) {
4221                     if (UTF)
4222                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8");
4223                     else if (PL_encoding) {
4224                         SV *name;
4225                         dSP;
4226                         ENTER;
4227                         SAVETMPS;
4228                         PUSHMARK(sp);
4229                         EXTEND(SP, 1);
4230                         XPUSHs(PL_encoding);
4231                         PUTBACK;
4232                         call_method("name", G_SCALAR);
4233                         SPAGAIN;
4234                         name = POPs;
4235                         PUTBACK;
4236                         PerlIO_apply_layers(aTHX_ PL_rsfp, NULL,
4237                                             Perl_form(aTHX_ ":encoding(%"SVf")",
4238                                                       name));
4239                         FREETMPS;
4240                         LEAVE;
4241                     }
4242                 }
4243 #endif
4244                 PL_rsfp = Nullfp;
4245             }
4246             goto fake_eof;
4247         }
4248
4249         case KEY_AUTOLOAD:
4250         case KEY_DESTROY:
4251         case KEY_BEGIN:
4252         case KEY_CHECK:
4253         case KEY_INIT:
4254         case KEY_END:
4255             if (PL_expect == XSTATE) {
4256                 s = PL_bufptr;
4257                 goto really_sub;
4258             }
4259             goto just_a_word;
4260
4261         case KEY_CORE:
4262             if (*s == ':' && s[1] == ':') {
4263                 s += 2;
4264                 d = s;
4265                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
4266                 if (!(tmp = keyword(PL_tokenbuf, len)))
4267                     Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
4268                 if (tmp < 0)
4269                     tmp = -tmp;
4270                 goto reserved_word;
4271             }
4272             goto just_a_word;
4273
4274         case KEY_abs:
4275             UNI(OP_ABS);
4276
4277         case KEY_alarm:
4278             UNI(OP_ALARM);
4279
4280         case KEY_accept:
4281             LOP(OP_ACCEPT,XTERM);
4282
4283         case KEY_and:
4284             OPERATOR(ANDOP);
4285
4286         case KEY_atan2:
4287             LOP(OP_ATAN2,XTERM);
4288
4289         case KEY_bind:
4290             LOP(OP_BIND,XTERM);
4291
4292         case KEY_binmode:
4293             LOP(OP_BINMODE,XTERM);
4294
4295         case KEY_bless:
4296             LOP(OP_BLESS,XTERM);
4297
4298         case KEY_chop:
4299             UNI(OP_CHOP);
4300
4301         case KEY_continue:
4302             PREBLOCK(CONTINUE);
4303
4304         case KEY_chdir:
4305             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
4306             UNI(OP_CHDIR);
4307
4308         case KEY_close:
4309             UNI(OP_CLOSE);
4310
4311         case KEY_closedir:
4312             UNI(OP_CLOSEDIR);
4313
4314         case KEY_cmp:
4315             Eop(OP_SCMP);
4316
4317         case KEY_caller:
4318             UNI(OP_CALLER);
4319
4320         case KEY_crypt:
4321 #ifdef FCRYPT
4322             if (!PL_cryptseen) {
4323                 PL_cryptseen = TRUE;
4324                 init_des();
4325             }
4326 #endif
4327             LOP(OP_CRYPT,XTERM);
4328
4329         case KEY_chmod:
4330             LOP(OP_CHMOD,XTERM);
4331
4332         case KEY_chown:
4333             LOP(OP_CHOWN,XTERM);
4334
4335         case KEY_connect:
4336             LOP(OP_CONNECT,XTERM);
4337
4338         case KEY_chr:
4339             UNI(OP_CHR);
4340
4341         case KEY_cos:
4342             UNI(OP_COS);
4343
4344         case KEY_chroot:
4345             UNI(OP_CHROOT);
4346
4347         case KEY_do:
4348             s = skipspace(s);
4349             if (*s == '{')
4350                 PRETERMBLOCK(DO);
4351             if (*s != '\'')
4352                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4353             OPERATOR(DO);
4354
4355         case KEY_die:
4356             PL_hints |= HINT_BLOCK_SCOPE;
4357             LOP(OP_DIE,XTERM);
4358
4359         case KEY_defined:
4360             UNI(OP_DEFINED);
4361
4362         case KEY_delete:
4363             UNI(OP_DELETE);
4364
4365         case KEY_dbmopen:
4366             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
4367             LOP(OP_DBMOPEN,XTERM);
4368
4369         case KEY_dbmclose:
4370             UNI(OP_DBMCLOSE);
4371
4372         case KEY_dump:
4373             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4374             LOOPX(OP_DUMP);
4375
4376         case KEY_else:
4377             PREBLOCK(ELSE);
4378
4379         case KEY_elsif:
4380             yylval.ival = CopLINE(PL_curcop);
4381             OPERATOR(ELSIF);
4382
4383         case KEY_eq:
4384             Eop(OP_SEQ);
4385
4386         case KEY_exists:
4387             UNI(OP_EXISTS);
4388
4389         case KEY_exit:
4390             UNI(OP_EXIT);
4391
4392         case KEY_eval:
4393             s = skipspace(s);
4394             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
4395             UNIBRACK(OP_ENTEREVAL);
4396
4397         case KEY_eof:
4398             UNI(OP_EOF);
4399
4400         case KEY_err:
4401             OPERATOR(DOROP);
4402
4403         case KEY_exp:
4404             UNI(OP_EXP);
4405
4406         case KEY_each:
4407             UNI(OP_EACH);
4408
4409         case KEY_exec:
4410             set_csh();
4411             LOP(OP_EXEC,XREF);
4412
4413         case KEY_endhostent:
4414             FUN0(OP_EHOSTENT);
4415
4416         case KEY_endnetent:
4417             FUN0(OP_ENETENT);
4418
4419         case KEY_endservent:
4420             FUN0(OP_ESERVENT);
4421
4422         case KEY_endprotoent:
4423             FUN0(OP_EPROTOENT);
4424
4425         case KEY_endpwent:
4426             FUN0(OP_EPWENT);
4427
4428         case KEY_endgrent:
4429             FUN0(OP_EGRENT);
4430
4431         case KEY_for:
4432         case KEY_foreach:
4433             yylval.ival = CopLINE(PL_curcop);
4434             s = skipspace(s);
4435             if (PL_expect == XSTATE && isIDFIRST_lazy_if(s,UTF)) {
4436                 char *p = s;
4437                 if ((PL_bufend - p) >= 3 &&
4438                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
4439                     p += 2;
4440                 else if ((PL_bufend - p) >= 4 &&
4441                     strnEQ(p, "our", 3) && isSPACE(*(p + 3)))
4442                     p += 3;
4443                 p = skipspace(p);
4444                 if (isIDFIRST_lazy_if(p,UTF)) {
4445                     p = scan_ident(p, PL_bufend,
4446                         PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
4447                     p = skipspace(p);
4448                 }
4449                 if (*p != '$')
4450                     Perl_croak(aTHX_ "Missing $ on loop variable");
4451             }
4452             OPERATOR(FOR);
4453
4454         case KEY_formline:
4455             LOP(OP_FORMLINE,XTERM);
4456
4457         case KEY_fork:
4458             FUN0(OP_FORK);
4459
4460         case KEY_fcntl:
4461             LOP(OP_FCNTL,XTERM);
4462
4463         case KEY_fileno:
4464             UNI(OP_FILENO);
4465
4466         case KEY_flock:
4467             LOP(OP_FLOCK,XTERM);
4468
4469         case KEY_gt:
4470             Rop(OP_SGT);
4471
4472         case KEY_ge:
4473             Rop(OP_SGE);
4474
4475         case KEY_grep:
4476             LOP(OP_GREPSTART, XREF);
4477
4478         case KEY_goto:
4479             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4480             LOOPX(OP_GOTO);
4481
4482         case KEY_gmtime:
4483             UNI(OP_GMTIME);
4484
4485         case KEY_getc:
4486             UNIDOR(OP_GETC);
4487
4488         case KEY_getppid:
4489             FUN0(OP_GETPPID);
4490
4491         case KEY_getpgrp:
4492             UNI(OP_GETPGRP);
4493
4494         case KEY_getpriority:
4495             LOP(OP_GETPRIORITY,XTERM);
4496
4497         case KEY_getprotobyname:
4498             UNI(OP_GPBYNAME);
4499
4500         case KEY_getprotobynumber:
4501             LOP(OP_GPBYNUMBER,XTERM);
4502
4503         case KEY_getprotoent:
4504             FUN0(OP_GPROTOENT);
4505
4506         case KEY_getpwent:
4507             FUN0(OP_GPWENT);
4508
4509         case KEY_getpwnam:
4510             UNI(OP_GPWNAM);
4511
4512         case KEY_getpwuid:
4513             UNI(OP_GPWUID);
4514
4515         case KEY_getpeername:
4516             UNI(OP_GETPEERNAME);
4517
4518         case KEY_gethostbyname:
4519             UNI(OP_GHBYNAME);
4520
4521         case KEY_gethostbyaddr:
4522             LOP(OP_GHBYADDR,XTERM);
4523
4524         case KEY_gethostent:
4525             FUN0(OP_GHOSTENT);
4526
4527         case KEY_getnetbyname:
4528             UNI(OP_GNBYNAME);
4529
4530         case KEY_getnetbyaddr:
4531             LOP(OP_GNBYADDR,XTERM);
4532
4533         case KEY_getnetent:
4534             FUN0(OP_GNETENT);
4535
4536         case KEY_getservbyname:
4537             LOP(OP_GSBYNAME,XTERM);
4538
4539         case KEY_getservbyport:
4540             LOP(OP_GSBYPORT,XTERM);
4541
4542         case KEY_getservent:
4543             FUN0(OP_GSERVENT);
4544
4545         case KEY_getsockname:
4546             UNI(OP_GETSOCKNAME);
4547
4548         case KEY_getsockopt:
4549             LOP(OP_GSOCKOPT,XTERM);
4550
4551         case KEY_getgrent:
4552             FUN0(OP_GGRENT);
4553
4554         case KEY_getgrnam:
4555             UNI(OP_GGRNAM);
4556
4557         case KEY_getgrgid:
4558             UNI(OP_GGRGID);
4559
4560         case KEY_getlogin:
4561             FUN0(OP_GETLOGIN);
4562
4563         case KEY_glob:
4564             set_csh();
4565             LOP(OP_GLOB,XTERM);
4566
4567         case KEY_hex:
4568             UNI(OP_HEX);
4569
4570         case KEY_if:
4571             yylval.ival = CopLINE(PL_curcop);
4572             OPERATOR(IF);
4573
4574         case KEY_index:
4575             LOP(OP_INDEX,XTERM);
4576
4577         case KEY_int:
4578             UNI(OP_INT);
4579
4580         case KEY_ioctl:
4581             LOP(OP_IOCTL,XTERM);
4582
4583         case KEY_join:
4584             LOP(OP_JOIN,XTERM);
4585
4586         case KEY_keys:
4587             UNI(OP_KEYS);
4588
4589         case KEY_kill:
4590             LOP(OP_KILL,XTERM);
4591
4592         case KEY_last:
4593             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4594             LOOPX(OP_LAST);
4595
4596         case KEY_lc:
4597             UNI(OP_LC);
4598
4599         case KEY_lcfirst:
4600             UNI(OP_LCFIRST);
4601
4602         case KEY_local:
4603             yylval.ival = 0;
4604             OPERATOR(LOCAL);
4605
4606         case KEY_length:
4607             UNI(OP_LENGTH);
4608
4609         case KEY_lt:
4610             Rop(OP_SLT);
4611
4612         case KEY_le:
4613             Rop(OP_SLE);
4614
4615         case KEY_localtime:
4616             UNI(OP_LOCALTIME);
4617
4618         case KEY_log:
4619             UNI(OP_LOG);
4620
4621         case KEY_link:
4622             LOP(OP_LINK,XTERM);
4623
4624         case KEY_listen:
4625             LOP(OP_LISTEN,XTERM);
4626
4627         case KEY_lock:
4628             UNI(OP_LOCK);
4629
4630         case KEY_lstat:
4631             UNI(OP_LSTAT);
4632
4633         case KEY_m:
4634             s = scan_pat(s,OP_MATCH);
4635             TERM(sublex_start());
4636
4637         case KEY_map:
4638             LOP(OP_MAPSTART, XREF);
4639
4640         case KEY_mkdir:
4641             LOP(OP_MKDIR,XTERM);
4642
4643         case KEY_msgctl:
4644             LOP(OP_MSGCTL,XTERM);
4645
4646         case KEY_msgget:
4647             LOP(OP_MSGGET,XTERM);
4648
4649         case KEY_msgrcv:
4650             LOP(OP_MSGRCV,XTERM);
4651
4652         case KEY_msgsnd:
4653             LOP(OP_MSGSND,XTERM);
4654
4655         case KEY_our:
4656         case KEY_my:
4657             PL_in_my = tmp;
4658             s = skipspace(s);
4659             if (isIDFIRST_lazy_if(s,UTF)) {
4660                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
4661                 if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
4662                     goto really_sub;
4663                 PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
4664                 if (!PL_in_my_stash) {
4665                     char tmpbuf[1024];
4666                     PL_bufptr = s;
4667                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
4668                     yyerror(tmpbuf);
4669                 }
4670             }
4671             yylval.ival = 1;
4672             OPERATOR(MY);
4673
4674         case KEY_next:
4675             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4676             LOOPX(OP_NEXT);
4677
4678         case KEY_ne:
4679             Eop(OP_SNE);
4680
4681         case KEY_no:
4682             if (PL_expect != XSTATE)
4683                 yyerror("\"no\" not allowed in expression");
4684             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4685             s = force_version(s, FALSE);
4686             yylval.ival = 0;
4687             OPERATOR(USE);
4688
4689         case KEY_not:
4690             if (*s == '(' || (s = skipspace(s), *s == '('))
4691                 FUN1(OP_NOT);
4692             else
4693                 OPERATOR(NOTOP);
4694
4695         case KEY_open:
4696             s = skipspace(s);
4697             if (isIDFIRST_lazy_if(s,UTF)) {
4698                 char *t;
4699                 for (d = s; isALNUM_lazy_if(d,UTF); d++) ;
4700                 t = skipspace(d);
4701                 if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)
4702                     /* [perl #16184] */
4703                     && !(t[0] == '=' && t[1] == '>')
4704                 ) {
4705                     Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
4706                            "Precedence problem: open %.*s should be open(%.*s)",
4707                             d - s, s, d - s, s);
4708                 }
4709             }
4710             LOP(OP_OPEN,XTERM);
4711
4712         case KEY_or:
4713             yylval.ival = OP_OR;
4714             OPERATOR(OROP);
4715
4716         case KEY_ord:
4717             UNI(OP_ORD);
4718
4719         case KEY_oct:
4720             UNI(OP_OCT);
4721
4722         case KEY_opendir:
4723             LOP(OP_OPEN_DIR,XTERM);
4724
4725         case KEY_print:
4726             checkcomma(s,PL_tokenbuf,"filehandle");
4727             LOP(OP_PRINT,XREF);
4728
4729         case KEY_printf:
4730             checkcomma(s,PL_tokenbuf,"filehandle");
4731             LOP(OP_PRTF,XREF);
4732
4733         case KEY_prototype:
4734             UNI(OP_PROTOTYPE);
4735
4736         case KEY_push:
4737             LOP(OP_PUSH,XTERM);
4738
4739         case KEY_pop:
4740             UNIDOR(OP_POP);
4741
4742         case KEY_pos:
4743             UNIDOR(OP_POS);
4744
4745         case KEY_pack:
4746             LOP(OP_PACK,XTERM);
4747
4748         case KEY_package:
4749             s = force_word(s,WORD,FALSE,TRUE,FALSE);
4750             OPERATOR(PACKAGE);
4751
4752         case KEY_pipe:
4753             LOP(OP_PIPE_OP,XTERM);
4754
4755         case KEY_q:
4756             s = scan_str(s,FALSE,FALSE);
4757             if (!s)
4758                 missingterm((char*)0);
4759             yylval.ival = OP_CONST;
4760             TERM(sublex_start());
4761
4762         case KEY_quotemeta:
4763             UNI(OP_QUOTEMETA);
4764
4765         case KEY_qw:
4766             s = scan_str(s,FALSE,FALSE);
4767             if (!s)
4768                 missingterm((char*)0);
4769             force_next(')');
4770             if (SvCUR(PL_lex_stuff)) {
4771                 OP *words = Nullop;
4772                 int warned = 0;
4773                 d = SvPV_force(PL_lex_stuff, len);
4774                 while (len) {
4775                     SV *sv;
4776                     for (; isSPACE(*d) && len; --len, ++d) ;
4777                     if (len) {
4778                         char *b = d;
4779                         if (!warned && ckWARN(WARN_QW)) {
4780                             for (; !isSPACE(*d) && len; --len, ++d) {
4781                                 if (*d == ',') {
4782                                     Perl_warner(aTHX_ packWARN(WARN_QW),
4783                                         "Possible attempt to separate words with commas");
4784                                     ++warned;
4785                                 }
4786                                 else if (*d == '#') {
4787                                     Perl_warner(aTHX_ packWARN(WARN_QW),
4788                                         "Possible attempt to put comments in qw() list");
4789                                     ++warned;
4790                                 }
4791                             }
4792                         }
4793                         else {
4794                             for (; !isSPACE(*d) && len; --len, ++d) ;
4795                         }
4796                         sv = newSVpvn(b, d-b);
4797                         if (DO_UTF8(PL_lex_stuff))
4798                             SvUTF8_on(sv);
4799                         words = append_elem(OP_LIST, words,
4800                                             newSVOP(OP_CONST, 0, tokeq(sv)));
4801                     }
4802                 }
4803                 if (words) {
4804                     PL_nextval[PL_nexttoke].opval = words;
4805                     force_next(THING);
4806                 }
4807             }
4808             if (PL_lex_stuff) {
4809                 SvREFCNT_dec(PL_lex_stuff);
4810                 PL_lex_stuff = Nullsv;
4811             }
4812             PL_expect = XTERM;
4813             TOKEN('(');
4814
4815         case KEY_qq:
4816             s = scan_str(s,FALSE,FALSE);
4817             if (!s)
4818                 missingterm((char*)0);
4819             yylval.ival = OP_STRINGIFY;
4820             if (SvIVX(PL_lex_stuff) == '\'')
4821                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
4822             TERM(sublex_start());
4823
4824         case KEY_qr:
4825             s = scan_pat(s,OP_QR);
4826             TERM(sublex_start());
4827
4828         case KEY_qx:
4829             s = scan_str(s,FALSE,FALSE);
4830             if (!s)
4831                 missingterm((char*)0);
4832             yylval.ival = OP_BACKTICK;
4833             set_csh();
4834             TERM(sublex_start());
4835
4836         case KEY_return:
4837             OLDLOP(OP_RETURN);
4838
4839         case KEY_require:
4840             s = skipspace(s);
4841             if (isDIGIT(*s)) {
4842                 s = force_version(s, FALSE);
4843             }
4844             else if (*s != 'v' || !isDIGIT(s[1])
4845                     || (s = force_version(s, TRUE), *s == 'v'))
4846             {
4847                 *PL_tokenbuf = '\0';
4848                 s = force_word(s,WORD,TRUE,TRUE,FALSE);
4849                 if (isIDFIRST_lazy_if(PL_tokenbuf,UTF))
4850                     gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
4851                 else if (*s == '<')
4852                     yyerror("<> should be quotes");
4853             }
4854             UNI(OP_REQUIRE);
4855
4856         case KEY_reset:
4857             UNI(OP_RESET);
4858
4859         case KEY_redo:
4860             s = force_word(s,WORD,TRUE,FALSE,FALSE);
4861             LOOPX(OP_REDO);
4862
4863         case KEY_rename:
4864             LOP(OP_RENAME,XTERM);
4865
4866         case KEY_rand:
4867             UNI(OP_RAND);
4868
4869         case KEY_rmdir:
4870             UNI(OP_RMDIR);
4871
4872         case KEY_rindex:
4873             LOP(OP_RINDEX,XTERM);
4874
4875         case KEY_read:
4876             LOP(OP_READ,XTERM);
4877
4878         case KEY_readdir:
4879             UNI(OP_READDIR);
4880
4881         case KEY_readline:
4882             set_csh();
4883             UNIDOR(OP_READLINE);
4884
4885         case KEY_readpipe:
4886             set_csh();
4887             UNI(OP_BACKTICK);
4888
4889         case KEY_rewinddir:
4890             UNI(OP_REWINDDIR);
4891
4892         case KEY_recv:
4893             LOP(OP_RECV,XTERM);
4894
4895         case KEY_reverse:
4896             LOP(OP_REVERSE,XTERM);
4897
4898         case KEY_readlink:
4899             UNIDOR(OP_READLINK);
4900
4901         case KEY_ref:
4902             UNI(OP_REF);
4903
4904         case KEY_s:
4905             s = scan_subst(s);
4906             if (yylval.opval)
4907                 TERM(sublex_start());
4908             else
4909                 TOKEN(1);       /* force error */
4910
4911         case KEY_chomp:
4912             UNI(OP_CHOMP);
4913
4914         case KEY_scalar:
4915             UNI(OP_SCALAR);
4916
4917         case KEY_select:
4918             LOP(OP_SELECT,XTERM);
4919
4920         case KEY_seek:
4921             LOP(OP_SEEK,XTERM);
4922
4923         case KEY_semctl:
4924             LOP(OP_SEMCTL,XTERM);
4925
4926         case KEY_semget:
4927             LOP(OP_SEMGET,XTERM);
4928
4929         case KEY_semop:
4930             LOP(OP_SEMOP,XTERM);
4931
4932         case KEY_send:
4933             LOP(OP_SEND,XTERM);
4934
4935         case KEY_setpgrp:
4936             LOP(OP_SETPGRP,XTERM);
4937
4938         case KEY_setpriority:
4939             LOP(OP_SETPRIORITY,XTERM);
4940
4941         case KEY_sethostent:
4942             UNI(OP_SHOSTENT);
4943
4944         case KEY_setnetent:
4945             UNI(OP_SNETENT);
4946
4947         case KEY_setservent:
4948             UNI(OP_SSERVENT);
4949
4950         case KEY_setprotoent:
4951             UNI(OP_SPROTOENT);
4952
4953         case KEY_setpwent:
4954             FUN0(OP_SPWENT);
4955
4956         case KEY_setgrent:
4957             FUN0(OP_SGRENT);
4958
4959         case KEY_seekdir:
4960             LOP(OP_SEEKDIR,XTERM);
4961
4962         case KEY_setsockopt:
4963             LOP(OP_SSOCKOPT,XTERM);
4964
4965         case KEY_shift:
4966             UNIDOR(OP_SHIFT);
4967
4968         case KEY_shmctl:
4969             LOP(OP_SHMCTL,XTERM);
4970
4971         case KEY_shmget:
4972             LOP(OP_SHMGET,XTERM);
4973
4974         case KEY_shmread:
4975             LOP(OP_SHMREAD,XTERM);
4976
4977         case KEY_shmwrite:
4978             LOP(OP_SHMWRITE,XTERM);
4979
4980         case KEY_shutdown:
4981             LOP(OP_SHUTDOWN,XTERM);
4982
4983         case KEY_sin:
4984             UNI(OP_SIN);
4985
4986         case KEY_sleep:
4987             UNI(OP_SLEEP);
4988
4989         case KEY_socket:
4990             LOP(OP_SOCKET,XTERM);
4991
4992         case KEY_socketpair:
4993             LOP(OP_SOCKPAIR,XTERM);
4994
4995         case KEY_sort:
4996             checkcomma(s,PL_tokenbuf,"subroutine name");
4997             s = skipspace(s);
4998             if (*s == ';' || *s == ')')         /* probably a close */
4999                 Perl_croak(aTHX_ "sort is now a reserved word");
5000             PL_expect = XTERM;
5001             s = force_word(s,WORD,TRUE,TRUE,FALSE);
5002             LOP(OP_SORT,XREF);
5003
5004         case KEY_split:
5005             LOP(OP_SPLIT,XTERM);
5006
5007         case KEY_sprintf:
5008             LOP(OP_SPRINTF,XTERM);
5009
5010         case KEY_splice:
5011             LOP(OP_SPLICE,XTERM);
5012
5013         case KEY_sqrt:
5014             UNI(OP_SQRT);
5015
5016         case KEY_srand:
5017             UNI(OP_SRAND);
5018
5019         case KEY_stat:
5020             UNI(OP_STAT);
5021
5022         case KEY_study:
5023             UNI(OP_STUDY);
5024
5025         case KEY_substr:
5026             LOP(OP_SUBSTR,XTERM);
5027
5028         case KEY_format:
5029         case KEY_sub:
5030           really_sub:
5031             {
5032                 char tmpbuf[sizeof PL_tokenbuf];
5033                 SSize_t tboffset = 0;
5034                 expectation attrful;
5035                 bool have_name, have_proto, bad_proto;
5036                 int key = tmp;
5037
5038                 s = skipspace(s);
5039
5040                 if (isIDFIRST_lazy_if(s,UTF) || *s == '\'' ||
5041                     (*s == ':' && s[1] == ':'))
5042                 {
5043                     PL_expect = XBLOCK;
5044                     attrful = XATTRBLOCK;
5045                     /* remember buffer pos'n for later force_word */
5046                     tboffset = s - PL_oldbufptr;
5047                     d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
5048                     if (strchr(tmpbuf, ':'))
5049                         sv_setpv(PL_subname, tmpbuf);
5050                     else {
5051                         sv_setsv(PL_subname,PL_curstname);
5052                         sv_catpvn(PL_subname,"::",2);
5053                         sv_catpvn(PL_subname,tmpbuf,len);
5054                     }
5055                     s = skipspace(d);
5056                     have_name = TRUE;
5057                 }
5058                 else {
5059                     if (key == KEY_my)
5060                         Perl_croak(aTHX_ "Missing name in \"my sub\"");
5061                     PL_expect = XTERMBLOCK;
5062                     attrful = XATTRTERM;
5063                     sv_setpv(PL_subname,"?");
5064                     have_name = FALSE;
5065                 }
5066
5067                 if (key == KEY_format) {
5068                     if (*s == '=')
5069                         PL_lex_formbrack = PL_lex_brackets + 1;
5070                     if (have_name)
5071                         (void) force_word(PL_oldbufptr + tboffset, WORD,
5072                                           FALSE, TRUE, TRUE);
5073                     OPERATOR(FORMAT);
5074                 }
5075
5076                 /* Look for a prototype */
5077                 if (*s == '(') {
5078                     char *p;
5079
5080                     s = scan_str(s,FALSE,FALSE);
5081                     if (!s)
5082                         Perl_croak(aTHX_ "Prototype not terminated");
5083                     /* strip spaces and check for bad characters */
5084                     d = SvPVX(PL_lex_stuff);
5085                     tmp = 0;
5086                     bad_proto = FALSE;
5087                     for (p = d; *p; ++p) {
5088                         if (!isSPACE(*p)) {
5089                             d[tmp++] = *p;
5090                             if (!strchr("$@%*;[]&\\", *p))
5091                                 bad_proto = TRUE;
5092                         }
5093                     }
5094                     d[tmp] = '\0';
5095                     if (bad_proto && ckWARN(WARN_SYNTAX))
5096                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5097                                     "Illegal character in prototype for %"SVf" : %s",
5098                                     PL_subname, d);
5099                     SvCUR(PL_lex_stuff) = tmp;
5100                     have_proto = TRUE;
5101
5102                     s = skipspace(s);
5103                 }
5104                 else
5105                     have_proto = FALSE;
5106
5107                 if (*s == ':' && s[1] != ':')
5108                     PL_expect = attrful;
5109                 else if (!have_name && *s != '{' && key == KEY_sub)
5110                     Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine");
5111
5112                 if (have_proto) {
5113                     PL_nextval[PL_nexttoke].opval =
5114                         (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
5115                     PL_lex_stuff = Nullsv;
5116                     force_next(THING);
5117                 }
5118                 if (!have_name) {
5119                     sv_setpv(PL_subname,
5120                         PL_curstash ? "__ANON__" : "__ANON__::__ANON__");
5121                     TOKEN(ANONSUB);
5122                 }
5123                 (void) force_word(PL_oldbufptr + tboffset, WORD,
5124                                   FALSE, TRUE, TRUE);
5125                 if (key == KEY_my)
5126                     TOKEN(MYSUB);
5127                 TOKEN(SUB);
5128             }
5129
5130         case KEY_system:
5131             set_csh();
5132             LOP(OP_SYSTEM,XREF);
5133
5134         case KEY_symlink:
5135             LOP(OP_SYMLINK,XTERM);
5136
5137         case KEY_syscall:
5138             LOP(OP_SYSCALL,XTERM);
5139
5140         case KEY_sysopen:
5141             LOP(OP_SYSOPEN,XTERM);
5142
5143         case KEY_sysseek:
5144             LOP(OP_SYSSEEK,XTERM);
5145
5146         case KEY_sysread:
5147             LOP(OP_SYSREAD,XTERM);
5148
5149         case KEY_syswrite:
5150             LOP(OP_SYSWRITE,XTERM);
5151
5152         case KEY_tr:
5153             s = scan_trans(s);
5154             TERM(sublex_start());
5155
5156         case KEY_tell:
5157             UNI(OP_TELL);
5158
5159         case KEY_telldir:
5160             UNI(OP_TELLDIR);
5161
5162         case KEY_tie:
5163             LOP(OP_TIE,XTERM);
5164
5165         case KEY_tied:
5166             UNI(OP_TIED);
5167
5168         case KEY_time:
5169             FUN0(OP_TIME);
5170
5171         case KEY_times:
5172             FUN0(OP_TMS);
5173
5174         case KEY_truncate:
5175             LOP(OP_TRUNCATE,XTERM);
5176
5177         case KEY_uc:
5178             UNI(OP_UC);
5179
5180         case KEY_ucfirst:
5181             UNI(OP_UCFIRST);
5182
5183         case KEY_untie:
5184             UNI(OP_UNTIE);
5185
5186         case KEY_until:
5187             yylval.ival = CopLINE(PL_curcop);
5188             OPERATOR(UNTIL);
5189
5190         case KEY_unless:
5191             yylval.ival = CopLINE(PL_curcop);
5192             OPERATOR(UNLESS);
5193
5194         case KEY_unlink:
5195             LOP(OP_UNLINK,XTERM);
5196
5197         case KEY_undef:
5198             UNIDOR(OP_UNDEF);
5199
5200         case KEY_unpack:
5201             LOP(OP_UNPACK,XTERM);
5202
5203         case KEY_utime:
5204             LOP(OP_UTIME,XTERM);
5205
5206         case KEY_umask:
5207             UNIDOR(OP_UMASK);
5208
5209         case KEY_unshift:
5210             LOP(OP_UNSHIFT,XTERM);
5211
5212         case KEY_use:
5213             if (PL_expect != XSTATE)
5214                 yyerror("\"use\" not allowed in expression");
5215             s = skipspace(s);
5216             if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
5217                 s = force_version(s, TRUE);
5218                 if (*s == ';' || (s = skipspace(s), *s == ';')) {
5219                     PL_nextval[PL_nexttoke].opval = Nullop;
5220                     force_next(WORD);
5221                 }
5222                 else if (*s == 'v') {
5223                     s = force_word(s,WORD,FALSE,TRUE,FALSE);
5224                     s = force_version(s, FALSE);
5225                 }
5226             }
5227             else {
5228                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
5229                 s = force_version(s, FALSE);
5230             }
5231             yylval.ival = 1;
5232             OPERATOR(USE);
5233
5234         case KEY_values:
5235             UNI(OP_VALUES);
5236
5237         case KEY_vec:
5238             LOP(OP_VEC,XTERM);
5239
5240         case KEY_while:
5241             yylval.ival = CopLINE(PL_curcop);
5242             OPERATOR(WHILE);
5243
5244         case KEY_warn:
5245             PL_hints |= HINT_BLOCK_SCOPE;
5246             LOP(OP_WARN,XTERM);
5247
5248         case KEY_wait:
5249             FUN0(OP_WAIT);
5250
5251         case KEY_waitpid:
5252             LOP(OP_WAITPID,XTERM);
5253
5254         case KEY_wantarray:
5255             FUN0(OP_WANTARRAY);
5256
5257         case KEY_write:
5258 #ifdef EBCDIC
5259         {
5260             char ctl_l[2];
5261             ctl_l[0] = toCTRL('L');
5262             ctl_l[1] = '\0';
5263             gv_fetchpv(ctl_l,TRUE, SVt_PV);
5264         }
5265 #else
5266             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
5267 #endif
5268             UNI(OP_ENTERWRITE);
5269
5270         case KEY_x:
5271             if (PL_expect == XOPERATOR)
5272                 Mop(OP_REPEAT);
5273             check_uni();
5274             goto just_a_word;
5275
5276         case KEY_xor:
5277             yylval.ival = OP_XOR;
5278             OPERATOR(OROP);
5279
5280         case KEY_y:
5281             s = scan_trans(s);
5282             TERM(sublex_start());
5283         }
5284     }}
5285 }
5286 #ifdef __SC__
5287 #pragma segment Main
5288 #endif
5289
5290 static int
5291 S_pending_ident(pTHX)
5292 {
5293     register char *d;
5294     register I32 tmp = 0;
5295     /* pit holds the identifier we read and pending_ident is reset */
5296     char pit = PL_pending_ident;
5297     PL_pending_ident = 0;
5298
5299     DEBUG_T({ PerlIO_printf(Perl_debug_log,
5300           "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
5301
5302     /* if we're in a my(), we can't allow dynamics here.
5303        $foo'bar has already been turned into $foo::bar, so
5304        just check for colons.
5305
5306        if it's a legal name, the OP is a PADANY.
5307     */
5308     if (PL_in_my) {
5309         if (PL_in_my == KEY_our) {      /* "our" is merely analogous to "my" */
5310             if (strchr(PL_tokenbuf,':'))
5311                 yyerror(Perl_form(aTHX_ "No package name allowed for "
5312                                   "variable %s in \"our\"",
5313                                   PL_tokenbuf));
5314             tmp = allocmy(PL_tokenbuf);
5315         }
5316         else {
5317             if (strchr(PL_tokenbuf,':'))
5318                 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
5319
5320             yylval.opval = newOP(OP_PADANY, 0);
5321             yylval.opval->op_targ = allocmy(PL_tokenbuf);
5322             return PRIVATEREF;
5323         }
5324     }
5325
5326     /*
5327        build the ops for accesses to a my() variable.
5328
5329        Deny my($a) or my($b) in a sort block, *if* $a or $b is
5330        then used in a comparison.  This catches most, but not
5331        all cases.  For instance, it catches
5332            sort { my($a); $a <=> $b }
5333        but not
5334            sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
5335        (although why you'd do that is anyone's guess).
5336     */
5337
5338     if (!strchr(PL_tokenbuf,':')) {
5339         if (!PL_in_my)
5340             tmp = pad_findmy(PL_tokenbuf);
5341         if (tmp != NOT_IN_PAD) {
5342             /* might be an "our" variable" */
5343             if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
5344                 /* build ops for a bareword */
5345                 SV *sym = newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)), 0);
5346                 sv_catpvn(sym, "::", 2);
5347                 sv_catpv(sym, PL_tokenbuf+1);
5348                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym);
5349                 yylval.opval->op_private = OPpCONST_ENTERED;
5350                 gv_fetchpv(SvPVX(sym),
5351                     (PL_in_eval
5352                         ? (GV_ADDMULTI | GV_ADDINEVAL)
5353                         : GV_ADDMULTI
5354                     ),
5355                     ((PL_tokenbuf[0] == '$') ? SVt_PV
5356                      : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5357                      : SVt_PVHV));
5358                 return WORD;
5359             }
5360
5361             /* if it's a sort block and they're naming $a or $b */
5362             if (PL_last_lop_op == OP_SORT &&
5363                 PL_tokenbuf[0] == '$' &&
5364                 (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
5365                 && !PL_tokenbuf[2])
5366             {
5367                 for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
5368                      d < PL_bufend && *d != '\n';
5369                      d++)
5370                 {
5371                     if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
5372                         Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
5373                               PL_tokenbuf);
5374                     }
5375                 }
5376             }
5377
5378             yylval.opval = newOP(OP_PADANY, 0);
5379             yylval.opval->op_targ = tmp;
5380             return PRIVATEREF;
5381         }
5382     }
5383
5384     /*
5385        Whine if they've said @foo in a doublequoted string,
5386        and @foo isn't a variable we can find in the symbol
5387        table.
5388     */
5389     if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
5390         GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
5391         if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
5392              && ckWARN(WARN_AMBIGUOUS))
5393         {
5394             /* Downgraded from fatal to warning 20000522 mjd */
5395             Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
5396                         "Possible unintended interpolation of %s in string",
5397                          PL_tokenbuf);
5398         }
5399     }
5400
5401     /* build ops for a bareword */
5402     yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
5403     yylval.opval->op_private = OPpCONST_ENTERED;
5404     gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
5405                ((PL_tokenbuf[0] == '$') ? SVt_PV
5406                 : (PL_tokenbuf[0] == '@') ? SVt_PVAV
5407                 : SVt_PVHV));
5408     return WORD;
5409 }
5410
5411 I32
5412 Perl_keyword(pTHX_ register char *d, I32 len)
5413 {
5414     switch (*d) {
5415     case '_':
5416         if (d[1] == '_') {
5417             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
5418             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
5419             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
5420             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
5421             if (strEQ(d,"__END__"))             return KEY___END__;
5422         }
5423         break;
5424     case 'A':
5425         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
5426         break;
5427     case 'a':
5428         switch (len) {
5429         case 3:
5430             if (strEQ(d,"and"))                 return -KEY_and;
5431             if (strEQ(d,"abs"))                 return -KEY_abs;
5432             break;
5433         case 5:
5434             if (strEQ(d,"alarm"))               return -KEY_alarm;
5435             if (strEQ(d,"atan2"))               return -KEY_atan2;
5436             break;
5437         case 6:
5438             if (strEQ(d,"accept"))              return -KEY_accept;
5439             break;
5440         }
5441         break;
5442     case 'B':
5443         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
5444         break;
5445     case 'b':
5446         if (strEQ(d,"bless"))                   return -KEY_bless;
5447         if (strEQ(d,"bind"))                    return -KEY_bind;
5448         if (strEQ(d,"binmode"))                 return -KEY_binmode;
5449         break;
5450     case 'C':
5451         if (strEQ(d,"CORE"))                    return -KEY_CORE;
5452         if (strEQ(d,"CHECK"))                   return KEY_CHECK;
5453         break;
5454     case 'c':
5455         switch (len) {
5456         case 3:
5457             if (strEQ(d,"cmp"))                 return -KEY_cmp;
5458             if (strEQ(d,"chr"))                 return -KEY_chr;
5459             if (strEQ(d,"cos"))                 return -KEY_cos;
5460             break;
5461         case 4:
5462             if (strEQ(d,"chop"))                return -KEY_chop;
5463             break;
5464         case 5:
5465             if (strEQ(d,"close"))               return -KEY_close;
5466             if (strEQ(d,"chdir"))               return -KEY_chdir;
5467             if (strEQ(d,"chomp"))               return -KEY_chomp;
5468             if (strEQ(d,"chmod"))               return -KEY_chmod;
5469             if (strEQ(d,"chown"))               return -KEY_chown;
5470             if (strEQ(d,"crypt"))               return -KEY_crypt;
5471             break;
5472         case 6:
5473             if (strEQ(d,"chroot"))              return -KEY_chroot;
5474             if (strEQ(d,"caller"))              return -KEY_caller;
5475             break;
5476         case 7:
5477             if (strEQ(d,"connect"))             return -KEY_connect;
5478             break;
5479         case 8:
5480             if (strEQ(d,"closedir"))            return -KEY_closedir;
5481             if (strEQ(d,"continue"))            return -KEY_continue;
5482             break;
5483         }
5484         break;
5485     case 'D':
5486         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
5487         break;
5488     case 'd':
5489         switch (len) {
5490         case 2:
5491             if (strEQ(d,"do"))                  return KEY_do;
5492             break;
5493         case 3:
5494             if (strEQ(d,"die"))                 return -KEY_die;
5495             break;
5496         case 4:
5497             if (strEQ(d,"dump"))                return -KEY_dump;
5498             break;
5499         case 6:
5500             if (strEQ(d,"delete"))              return KEY_delete;
5501             break;
5502         case 7:
5503             if (strEQ(d,"defined"))             return KEY_defined;
5504             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
5505             break;
5506         case 8:
5507             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
5508             break;
5509         }
5510         break;
5511     case 'E':
5512         if (strEQ(d,"END"))                     return KEY_END;
5513         break;
5514     case 'e':
5515         switch (len) {
5516         case 2:
5517             if (strEQ(d,"eq"))                  return -KEY_eq;
5518             break;
5519         case 3:
5520             if (strEQ(d,"eof"))                 return -KEY_eof;
5521             if (strEQ(d,"err"))                 return -KEY_err;
5522             if (strEQ(d,"exp"))                 return -KEY_exp;
5523             break;
5524         case 4:
5525             if (strEQ(d,"else"))                return KEY_else;
5526             if (strEQ(d,"exit"))                return -KEY_exit;
5527             if (strEQ(d,"eval"))                return KEY_eval;
5528             if (strEQ(d,"exec"))                return -KEY_exec;
5529            if (strEQ(d,"each"))                return -KEY_each;
5530             break;
5531         case 5:
5532             if (strEQ(d,"elsif"))               return KEY_elsif;
5533             break;
5534         case 6:
5535             if (strEQ(d,"exists"))              return KEY_exists;
5536             if (strEQ(d,"elseif") && ckWARN_d(WARN_SYNTAX))
5537                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
5538                         "elseif should be elsif");
5539             break;
5540         case 8:
5541             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
5542             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
5543             break;
5544         case 9:
5545             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
5546             break;
5547         case 10:
5548             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
5549             if (strEQ(d,"endservent"))          return -KEY_endservent;
5550             break;
5551         case 11:
5552             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
5553             break;
5554         }
5555         break;
5556     case 'f':
5557         switch (len) {
5558         case 3:
5559             if (strEQ(d,"for"))                 return KEY_for;
5560             break;
5561         case 4:
5562             if (strEQ(d,"fork"))                return -KEY_fork;
5563             break;
5564         case 5:
5565             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
5566             if (strEQ(d,"flock"))               return -KEY_flock;
5567             break;
5568         case 6:
5569             if (strEQ(d,"format"))              return KEY_format;
5570             if (strEQ(d,"fileno"))              return -KEY_fileno;
5571             break;
5572         case 7:
5573             if (strEQ(d,"foreach"))             return KEY_foreach;
5574             break;
5575         case 8:
5576             if (strEQ(d,"formline"))            return -KEY_formline;
5577             break;
5578         }
5579         break;
5580     case 'g':
5581         if (strnEQ(d,"get",3)) {
5582             d += 3;
5583             if (*d == 'p') {
5584                 switch (len) {
5585                 case 7:
5586                     if (strEQ(d,"ppid"))        return -KEY_getppid;
5587                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
5588                     break;
5589                 case 8:
5590                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
5591                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
5592                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
5593                     break;
5594                 case 11:
5595                     if (strEQ(d,"peername"))    return -KEY_getpeername;
5596                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
5597                     if (strEQ(d,"priority"))    return -KEY_getpriority;
5598                     break;
5599                 case 14:
5600                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
5601                     break;
5602                 case 16:
5603                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
5604                     break;
5605                 }
5606             }
5607             else if (*d == 'h') {
5608                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
5609                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
5610                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
5611             }
5612             else if (*d == 'n') {
5613                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
5614                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
5615                 if (strEQ(d,"netent"))          return -KEY_getnetent;
5616             }
5617             else if (*d == 's') {
5618                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
5619                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
5620                 if (strEQ(d,"servent"))         return -KEY_getservent;
5621                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
5622                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
5623             }
5624             else if (*d == 'g') {
5625                 if (strEQ(d,"grent"))           return -KEY_getgrent;
5626                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
5627                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
5628             }
5629             else if (*d == 'l') {
5630                 if (strEQ(d,"login"))           return -KEY_getlogin;
5631             }
5632             else if (strEQ(d,"c"))              return -KEY_getc;
5633             break;
5634         }
5635         switch (len) {
5636         case 2:
5637             if (strEQ(d,"gt"))                  return -KEY_gt;
5638             if (strEQ(d,"ge"))                  return -KEY_ge;
5639             break;
5640         case 4:
5641             if (strEQ(d,"grep"))                return KEY_grep;
5642             if (strEQ(d,"goto"))                return KEY_goto;
5643             if (strEQ(d,"glob"))                return KEY_glob;
5644             break;
5645         case 6:
5646             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
5647             break;
5648         }
5649         break;
5650     case 'h':
5651         if (strEQ(d,"hex"))                     return -KEY_hex;
5652         break;
5653     case 'I':
5654         if (strEQ(d,"INIT"))                    return KEY_INIT;
5655         break;
5656     case 'i':
5657         switch (len) {
5658         case 2:
5659             if (strEQ(d,"if"))                  return KEY_if;
5660             break;
5661         case 3:
5662             if (strEQ(d,"int"))                 return -KEY_int;
5663             break;
5664         case 5:
5665             if (strEQ(d,"index"))               return -KEY_index;
5666             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
5667             break;
5668         }
5669         break;
5670     case 'j':
5671         if (strEQ(d,"join"))                    return -KEY_join;
5672         break;
5673     case 'k':
5674         if (len == 4) {
5675            if (strEQ(d,"keys"))                return -KEY_keys;
5676             if (strEQ(d,"kill"))                return -KEY_kill;
5677         }
5678         break;
5679     case 'l':
5680         switch (len) {
5681         case 2:
5682             if (strEQ(d,"lt"))                  return -KEY_lt;
5683             if (strEQ(d,"le"))                  return -KEY_le;
5684             if (strEQ(d,"lc"))                  return -KEY_lc;
5685             break;
5686         case 3:
5687             if (strEQ(d,"log"))                 return -KEY_log;
5688             break;
5689         case 4:
5690             if (strEQ(d,"last"))                return KEY_last;
5691             if (strEQ(d,"link"))                return -KEY_link;
5692             if (strEQ(d,"lock"))                return -KEY_lock;
5693             break;
5694         case 5:
5695             if (strEQ(d,"local"))               return KEY_local;
5696             if (strEQ(d,"lstat"))               return -KEY_lstat;
5697             break;
5698         case 6:
5699             if (strEQ(d,"length"))              return -KEY_length;
5700             if (strEQ(d,"listen"))              return -KEY_listen;
5701             break;
5702         case 7:
5703             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
5704             break;
5705         case 9:
5706             if (strEQ(d,"localtime"))           return -KEY_localtime;
5707             break;
5708         }
5709         break;
5710     case 'm':
5711         switch (len) {
5712         case 1:                                 return KEY_m;
5713         case 2:
5714             if (strEQ(d,"my"))                  return KEY_my;
5715             break;
5716         case 3:
5717             if (strEQ(d,"map"))                 return KEY_map;
5718             break;
5719         case 5:
5720             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
5721             break;
5722         case 6:
5723             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
5724             if (strEQ(d,"msgget"))              return -KEY_msgget;
5725             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
5726             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
5727             break;
5728         }
5729         break;
5730     case 'n':
5731         if (strEQ(d,"next"))                    return KEY_next;
5732         if (strEQ(d,"ne"))                      return -KEY_ne;
5733         if (strEQ(d,"not"))                     return -KEY_not;
5734         if (strEQ(d,"no"))                      return KEY_no;
5735         break;
5736     case 'o':
5737         switch (len) {
5738         case 2:
5739             if (strEQ(d,"or"))                  return -KEY_or;
5740             break;
5741         case 3:
5742             if (strEQ(d,"ord"))                 return -KEY_ord;
5743             if (strEQ(d,"oct"))                 return -KEY_oct;
5744             if (strEQ(d,"our"))                 return KEY_our;
5745             break;
5746         case 4:
5747             if (strEQ(d,"open"))                return -KEY_open;
5748             break;
5749         case 7:
5750             if (strEQ(d,"opendir"))             return -KEY_opendir;
5751             break;
5752         }
5753         break;
5754     case 'p':
5755         switch (len) {
5756         case 3:
5757            if (strEQ(d,"pop"))                 return -KEY_pop;
5758             if (strEQ(d,"pos"))                 return KEY_pos;
5759             break;
5760         case 4:
5761            if (strEQ(d,"push"))                return -KEY_push;
5762             if (strEQ(d,"pack"))                return -KEY_pack;
5763             if (strEQ(d,"pipe"))                return -KEY_pipe;
5764             break;
5765         case 5:
5766             if (strEQ(d,"print"))               return KEY_print;
5767             break;
5768         case 6:
5769             if (strEQ(d,"printf"))              return KEY_printf;
5770             break;
5771         case 7:
5772             if (strEQ(d,"package"))             return KEY_package;
5773             break;
5774         case 9:
5775             if (strEQ(d,"prototype"))           return KEY_prototype;
5776         }
5777         break;
5778     case 'q':
5779         if (len <= 2) {
5780             if (strEQ(d,"q"))                   return KEY_q;
5781             if (strEQ(d,"qr"))                  return KEY_qr;
5782             if (strEQ(d,"qq"))                  return KEY_qq;
5783             if (strEQ(d,"qw"))                  return KEY_qw;
5784             if (strEQ(d,"qx"))                  return KEY_qx;
5785         }
5786         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
5787         break;
5788     case 'r':
5789         switch (len) {
5790         case 3:
5791             if (strEQ(d,"ref"))                 return -KEY_ref;
5792             break;
5793         case 4:
5794             if (strEQ(d,"read"))                return -KEY_read;
5795             if (strEQ(d,"rand"))                return -KEY_rand;
5796             if (strEQ(d,"recv"))                return -KEY_recv;
5797             if (strEQ(d,"redo"))                return KEY_redo;
5798             break;
5799         case 5:
5800             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
5801             if (strEQ(d,"reset"))               return -KEY_reset;
5802             break;
5803         case 6:
5804             if (strEQ(d,"return"))              return KEY_return;
5805             if (strEQ(d,"rename"))              return -KEY_rename;
5806             if (strEQ(d,"rindex"))              return -KEY_rindex;
5807             break;
5808         case 7:
5809             if (strEQ(d,"require"))             return KEY_require;
5810             if (strEQ(d,"reverse"))             return -KEY_reverse;
5811             if (strEQ(d,"readdir"))             return -KEY_readdir;
5812             break;
5813         case 8:
5814             if (strEQ(d,"readlink"))            return -KEY_readlink;
5815             if (strEQ(d,"readline"))            return -KEY_readline;
5816             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
5817             break;
5818         case 9:
5819             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
5820             break;
5821         }
5822         break;
5823     case 's':
5824         switch (d[1]) {
5825         case 0:                                 return KEY_s;
5826         case 'c':
5827             if (strEQ(d,"scalar"))              return KEY_scalar;
5828             break;
5829         case 'e':
5830             switch (len) {
5831             case 4:
5832                 if (strEQ(d,"seek"))            return -KEY_seek;
5833                 if (strEQ(d,"send"))            return -KEY_send;
5834                 break;
5835             case 5:
5836                 if (strEQ(d,"semop"))           return -KEY_semop;
5837                 break;
5838             case 6:
5839                 if (strEQ(d,"select"))          return -KEY_select;
5840                 if (strEQ(d,"semctl"))          return -KEY_semctl;
5841                 if (strEQ(d,"semget"))          return -KEY_semget;
5842                 break;
5843             case 7:
5844                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
5845                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
5846                 break;
5847             case 8:
5848                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
5849                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
5850                 break;
5851             case 9:
5852                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
5853                 break;
5854             case 10:
5855                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
5856                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
5857                 if (strEQ(d,"setservent"))      return -KEY_setservent;
5858                 break;
5859             case 11:
5860                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
5861                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
5862                 break;
5863             }
5864             break;
5865         case 'h':
5866             switch (len) {
5867             case 5:
5868                if (strEQ(d,"shift"))           return -KEY_shift;
5869                 break;
5870             case 6:
5871                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
5872                 if (strEQ(d,"shmget"))          return -KEY_shmget;
5873                 break;
5874             case 7:
5875                 if (strEQ(d,"shmread"))         return -KEY_shmread;
5876                 break;
5877             case 8:
5878                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
5879                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
5880                 break;
5881             }
5882             break;
5883         case 'i':
5884             if (strEQ(d,"sin"))                 return -KEY_sin;
5885             break;
5886         case 'l':
5887             if (strEQ(d,"sleep"))               return -KEY_sleep;
5888             break;
5889         case 'o':
5890             if (strEQ(d,"sort"))                return KEY_sort;
5891             if (strEQ(d,"socket"))              return -KEY_socket;
5892             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
5893             break;
5894         case 'p':
5895             if (strEQ(d,"split"))               return KEY_split;
5896             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
5897            if (strEQ(d,"splice"))              return -KEY_splice;
5898             break;
5899         case 'q':
5900             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
5901             break;
5902         case 'r':
5903             if (strEQ(d,"srand"))               return -KEY_srand;
5904             break;
5905         case 't':
5906             if (strEQ(d,"stat"))                return -KEY_stat;
5907             if (strEQ(d,"study"))               return KEY_study;
5908             break;
5909         case 'u':
5910             if (strEQ(d,"substr"))              return -KEY_substr;
5911             if (strEQ(d,"sub"))                 return KEY_sub;
5912             break;
5913         case 'y':
5914             switch (len) {
5915             case 6:
5916                 if (strEQ(d,"system"))          return -KEY_system;
5917                 break;
5918             case 7:
5919                 if (strEQ(d,"symlink"))         return -KEY_symlink;
5920                 if (strEQ(d,"syscall"))         return -KEY_syscall;
5921                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
5922                 if (strEQ(d,"sysread"))         return -KEY_sysread;
5923                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
5924                 break;
5925             case 8:
5926                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
5927                 break;
5928             }
5929             break;
5930         }
5931         break;
5932     case 't':
5933         switch (len) {
5934         case 2:
5935             if (strEQ(d,"tr"))                  return KEY_tr;
5936             break;
5937         case 3:
5938             if (strEQ(d,"tie"))                 return KEY_tie;
5939             break;
5940         case 4:
5941             if (strEQ(d,"tell"))                return -KEY_tell;
5942             if (strEQ(d,"tied"))                return KEY_tied;
5943             if (strEQ(d,"time"))                return -KEY_time;
5944             break;
5945         case 5:
5946             if (strEQ(d,"times"))               return -KEY_times;
5947             break;
5948         case 7:
5949             if (strEQ(d,"telldir"))             return -KEY_telldir;
5950             break;
5951         case 8:
5952             if (strEQ(d,"truncate"))            return -KEY_truncate;
5953             break;
5954         }
5955         break;
5956     case 'u':
5957         switch (len) {
5958         case 2:
5959             if (strEQ(d,"uc"))                  return -KEY_uc;
5960             break;
5961         case 3:
5962             if (strEQ(d,"use"))                 return KEY_use;
5963             break;
5964         case 5:
5965             if (strEQ(d,"undef"))               return KEY_undef;
5966             if (strEQ(d,"until"))               return KEY_until;
5967             if (strEQ(d,"untie"))               return KEY_untie;
5968             if (strEQ(d,"utime"))               return -KEY_utime;
5969             if (strEQ(d,"umask"))               return -KEY_umask;
5970             break;
5971         case 6:
5972             if (strEQ(d,"unless"))              return KEY_unless;
5973             if (strEQ(d,"unpack"))              return -KEY_unpack;
5974             if (strEQ(d,"unlink"))              return -KEY_unlink;
5975             break;
5976         case 7:
5977            if (strEQ(d,"unshift"))             return -KEY_unshift;
5978             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
5979             break;
5980         }
5981         break;
5982     case 'v':
5983         if (strEQ(d,"values"))                  return -KEY_values;
5984         if (strEQ(d,"vec"))                     return -KEY_vec;
5985         break;
5986     case 'w':
5987         switch (len) {
5988         case 4:
5989             if (strEQ(d,"warn"))                return -KEY_warn;
5990             if (strEQ(d,"wait"))                return -KEY_wait;
5991             break;
5992         case 5:
5993             if (strEQ(d,"while"))               return KEY_while;
5994             if (strEQ(d,"write"))               return -KEY_write;
5995             break;
5996         case 7:
5997             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
5998             break;
5999         case 9:
6000             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
6001             break;
6002         }
6003         break;
6004     case 'x':
6005         if (len == 1)                           return -KEY_x;
6006         if (strEQ(d,"xor"))                     return -KEY_xor;
6007         break;
6008     case 'y':
6009         if (len == 1)                           return KEY_y;
6010         break;
6011     case 'z':
6012         break;
6013     }
6014     return 0;
6015 }
6016
6017 STATIC void
6018 S_checkcomma(pTHX_ register char *s, char *name, char *what)
6019 {
6020     char *w;
6021
6022     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
6023         if (ckWARN(WARN_SYNTAX)) {
6024             int level = 1;
6025             for (w = s+2; *w && level; w++) {
6026                 if (*w == '(')
6027                     ++level;
6028                 else if (*w == ')')
6029                     --level;
6030             }
6031             if (*w)
6032                 for (; *w && isSPACE(*w); w++) ;
6033             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
6034                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
6035                             "%s (...) interpreted as function",name);
6036         }
6037     }
6038     while (s < PL_bufend && isSPACE(*s))
6039         s++;
6040     if (*s == '(')
6041         s++;
6042     while (s < PL_bufend && isSPACE(*s))
6043         s++;
6044     if (isIDFIRST_lazy_if(s,UTF)) {
6045         w = s++;
6046         while (isALNUM_lazy_if(s,UTF))
6047             s++;
6048         while (s < PL_bufend && isSPACE(*s))
6049             s++;
6050         if (*s == ',') {
6051             int kw;
6052             *s = '\0';
6053             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
6054             *s = ',';
6055             if (kw)
6056                 return;
6057             Perl_croak(aTHX_ "No comma allowed after %s", what);
6058         }
6059     }
6060 }
6061
6062 /* Either returns sv, or mortalizes sv and returns a new SV*.
6063    Best used as sv=new_constant(..., sv, ...).
6064    If s, pv are NULL, calls subroutine with one argument,
6065    and type is used with error messages only. */
6066
6067 STATIC SV *
6068 S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
6069                const char *type)
6070 {
6071     dSP;
6072     HV *table = GvHV(PL_hintgv);                 /* ^H */
6073     SV *res;
6074     SV **cvp;
6075     SV *cv, *typesv;
6076     const char *why1, *why2, *why3;
6077
6078     if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
6079         SV *msg;
6080
6081         why2 = strEQ(key,"charnames")
6082                ? "(possibly a missing \"use charnames ...\")"
6083                : "";
6084         msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s",
6085                             (type ? type: "undef"), why2);
6086
6087         /* This is convoluted and evil ("goto considered harmful")
6088          * but I do not understand the intricacies of all the different
6089          * failure modes of %^H in here.  The goal here is to make
6090          * the most probable error message user-friendly. --jhi */
6091
6092         goto msgdone;
6093
6094     report:
6095         msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s",
6096                             (type ? type: "undef"), why1, why2, why3);
6097     msgdone:
6098         yyerror(SvPVX(msg));
6099         SvREFCNT_dec(msg);
6100         return sv;
6101     }
6102     cvp = hv_fetch(table, key, strlen(key), FALSE);
6103     if (!cvp || !SvOK(*cvp)) {
6104         why1 = "$^H{";
6105         why2 = key;
6106         why3 = "} is not defined";
6107         goto report;
6108     }
6109     sv_2mortal(sv);                     /* Parent created it permanently */
6110     cv = *cvp;
6111     if (!pv && s)
6112         pv = sv_2mortal(newSVpvn(s, len));
6113     if (type && pv)
6114         typesv = sv_2mortal(newSVpv(type, 0));
6115     else
6116         typesv = &PL_sv_undef;
6117
6118     PUSHSTACKi(PERLSI_OVERLOAD);
6119     ENTER ;
6120     SAVETMPS;
6121
6122     PUSHMARK(SP) ;
6123     EXTEND(sp, 3);
6124     if (pv)
6125         PUSHs(pv);
6126     PUSHs(sv);
6127     if (pv)
6128         PUSHs(typesv);
6129     PUTBACK;
6130     call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL));
6131
6132     SPAGAIN ;
6133
6134     /* Check the eval first */
6135     if (!PL_in_eval && SvTRUE(ERRSV)) {
6136         STRLEN n_a;
6137         sv_catpv(ERRSV, "Propagated");
6138         yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */
6139         (void)POPs;
6140         res = SvREFCNT_inc(sv);
6141     }
6142     else {
6143         res = POPs;
6144         (void)SvREFCNT_inc(res);
6145     }
6146
6147     PUTBACK ;
6148     FREETMPS ;
6149     LEAVE ;
6150     POPSTACK;
6151
6152     if (!SvOK(res)) {
6153         why1 = "Call to &{$^H{";
6154         why2 = key;
6155         why3 = "}} did not return a defined value";
6156         sv = res;
6157         goto report;
6158     }
6159
6160     return res;
6161 }
6162
6163 STATIC char *
6164 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
6165 {
6166     register char *d = dest;
6167     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
6168     for (;;) {
6169         if (d >= e)
6170             Perl_croak(aTHX_ ident_too_long);
6171         if (isALNUM(*s))        /* UTF handled below */
6172             *d++ = *s++;
6173         else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) {
6174             *d++ = ':';
6175             *d++ = ':';
6176             s++;
6177         }
6178         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
6179             *d++ = *s++;
6180             *d++ = *s++;
6181         }
6182         else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6183             char *t = s + UTF8SKIP(s);
6184             while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6185                 t += UTF8SKIP(t);
6186             if (d + (t - s) > e)
6187                 Perl_croak(aTHX_ ident_too_long);
6188             Copy(s, d, t - s, char);
6189             d += t - s;
6190             s = t;
6191         }
6192         else {
6193             *d = '\0';
6194             *slp = d - dest;
6195             return s;
6196         }
6197     }
6198 }
6199
6200 STATIC char *
6201 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
6202 {
6203     register char *d;
6204     register char *e;
6205     char *bracket = 0;
6206     char funny = *s++;
6207
6208     if (isSPACE(*s))
6209         s = skipspace(s);
6210     d = dest;
6211     e = d + destlen - 3;        /* two-character token, ending NUL */
6212     if (isDIGIT(*s)) {
6213         while (isDIGIT(*s)) {
6214             if (d >= e)
6215                 Perl_croak(aTHX_ ident_too_long);
6216             *d++ = *s++;
6217         }
6218     }
6219     else {
6220         for (;;) {
6221             if (d >= e)
6222                 Perl_croak(aTHX_ ident_too_long);
6223             if (isALNUM(*s))    /* UTF handled below */
6224                 *d++ = *s++;
6225             else if (*s == '\'' && isIDFIRST_lazy_if(s+1,UTF)) {
6226                 *d++ = ':';
6227                 *d++ = ':';
6228                 s++;
6229             }
6230             else if (*s == ':' && s[1] == ':') {
6231                 *d++ = *s++;
6232                 *d++ = *s++;
6233             }
6234             else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) {
6235                 char *t = s + UTF8SKIP(s);
6236                 while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t))
6237                     t += UTF8SKIP(t);
6238                 if (d + (t - s) > e)
6239                     Perl_croak(aTHX_ ident_too_long);
6240                 Copy(s, d, t - s, char);
6241                 d += t - s;
6242                 s = t;
6243             }
6244             else
6245                 break;
6246         }
6247     }
6248     *d = '\0';
6249     d = dest;
6250     if (*d) {
6251         if (PL_lex_state != LEX_NORMAL)
6252             PL_lex_state = LEX_INTERPENDMAYBE;
6253         return s;
6254     }
6255     if (*s == '$' && s[1] &&
6256         (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
6257     {
6258         return s;
6259     }
6260     if (*s == '{') {
6261         bracket = s;
6262         s++;
6263     }
6264     else if (ck_uni)
6265         check_uni();
6266     if (s < send)
6267         *d = *s++;
6268     d[1] = '\0';
6269     if (*d == '^' && *s && isCONTROLVAR(*s)) {
6270         *d = toCTRL(*s);
6271         s++;
6272     }
6273     if (bracket) {
6274         if (isSPACE(s[-1])) {
6275             while (s < send) {
6276                 char ch = *s++;
6277                 if (!SPACE_OR_TAB(ch)) {
6278                     *d = ch;
6279                     break;
6280                 }
6281             }
6282         }
6283         if (isIDFIRST_lazy_if(d,UTF)) {
6284             d++;
6285             if (UTF) {
6286                 e = s;
6287                 while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') {
6288                     e += UTF8SKIP(e);
6289                     while (e < send && UTF8_IS_CONTINUED(*e) && is_utf8_mark((U8*)e))
6290                         e += UTF8SKIP(e);
6291                 }
6292                 Copy(s, d, e - s, char);
6293                 d += e - s;
6294                 s = e;
6295             }
6296             else {
6297                 while ((isALNUM(*s) || *s == ':') && d < e)
6298                     *d++ = *s++;
6299                 if (d >= e)
6300                     Perl_croak(aTHX_ ident_too_long);
6301             }
6302             *d = '\0';
6303             while (s < send && SPACE_OR_TAB(*s)) s++;
6304             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
6305                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
6306                     const char *brack = *s == '[' ? "[...]" : "{...}";
6307                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6308                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
6309                         funny, dest, brack, funny, dest, brack);
6310                 }
6311                 bracket++;
6312                 PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK);
6313                 return s;
6314             }
6315         }
6316         /* Handle extended ${^Foo} variables
6317          * 1999-02-27 mjd-perl-patch@plover.com */
6318         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
6319                  && isALNUM(*s))
6320         {
6321             d++;
6322             while (isALNUM(*s) && d < e) {
6323                 *d++ = *s++;
6324             }
6325             if (d >= e)
6326                 Perl_croak(aTHX_ ident_too_long);
6327             *d = '\0';
6328         }
6329         if (*s == '}') {
6330             s++;
6331             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) {
6332                 PL_lex_state = LEX_INTERPEND;
6333                 PL_expect = XREF;
6334             }
6335             if (funny == '#')
6336                 funny = '@';
6337             if (PL_lex_state == LEX_NORMAL) {
6338                 if (ckWARN(WARN_AMBIGUOUS) &&
6339                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
6340                 {
6341                     Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
6342                         "Ambiguous use of %c{%s} resolved to %c%s",
6343                         funny, dest, funny, dest);
6344                 }
6345             }
6346         }
6347         else {
6348             s = bracket;                /* let the parser handle it */
6349             *dest = '\0';
6350         }
6351     }
6352     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
6353         PL_lex_state = LEX_INTERPEND;
6354     return s;
6355 }
6356
6357 void
6358 Perl_pmflag(pTHX_ U32* pmfl, int ch)
6359 {
6360     if (ch == 'i')
6361         *pmfl |= PMf_FOLD;
6362     else if (ch == 'g')
6363         *pmfl |= PMf_GLOBAL;
6364     else if (ch == 'c')
6365         *pmfl |= PMf_CONTINUE;
6366     else if (ch == 'o')
6367         *pmfl |= PMf_KEEP;
6368     else if (ch == 'm')
6369         *pmfl |= PMf_MULTILINE;
6370     else if (ch == 's')
6371         *pmfl |= PMf_SINGLELINE;
6372     else if (ch == 'x')
6373         *pmfl |= PMf_EXTENDED;
6374 }
6375
6376 STATIC char *
6377 S_scan_pat(pTHX_ char *start, I32 type)
6378 {
6379     PMOP *pm;
6380     char *s;
6381
6382     s = scan_str(start,FALSE,FALSE);
6383     if (!s)
6384         Perl_croak(aTHX_ "Search pattern not terminated");
6385
6386     pm = (PMOP*)newPMOP(type, 0);
6387     if (PL_multi_open == '?')
6388         pm->op_pmflags |= PMf_ONCE;
6389     if(type == OP_QR) {
6390         while (*s && strchr("iomsx", *s))
6391             pmflag(&pm->op_pmflags,*s++);
6392     }
6393     else {
6394         while (*s && strchr("iogcmsx", *s))
6395             pmflag(&pm->op_pmflags,*s++);
6396     }
6397     /* issue a warning if /c is specified,but /g is not */
6398     if (ckWARN(WARN_REGEXP) &&
6399         (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
6400     {
6401         Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
6402     }
6403
6404     pm->op_pmpermflags = pm->op_pmflags;
6405
6406     PL_lex_op = (OP*)pm;
6407     yylval.ival = OP_MATCH;
6408     return s;
6409 }
6410
6411 STATIC char *
6412 S_scan_subst(pTHX_ char *start)
6413 {
6414     register char *s;
6415     register PMOP *pm;
6416     I32 first_start;
6417     I32 es = 0;
6418
6419     yylval.ival = OP_NULL;
6420
6421     s = scan_str(start,FALSE,FALSE);
6422
6423     if (!s)
6424         Perl_croak(aTHX_ "Substitution pattern not terminated");
6425
6426     if (s[-1] == PL_multi_open)
6427         s--;
6428
6429     first_start = PL_multi_start;
6430     s = scan_str(s,FALSE,FALSE);
6431     if (!s) {
6432         if (PL_lex_stuff) {
6433             SvREFCNT_dec(PL_lex_stuff);
6434             PL_lex_stuff = Nullsv;
6435         }
6436         Perl_croak(aTHX_ "Substitution replacement not terminated");
6437     }
6438     PL_multi_start = first_start;       /* so whole substitution is taken together */
6439
6440     pm = (PMOP*)newPMOP(OP_SUBST, 0);
6441     while (*s) {
6442         if (*s == 'e') {
6443             s++;
6444             es++;
6445         }
6446         else if (strchr("iogcmsx", *s))
6447             pmflag(&pm->op_pmflags,*s++);
6448         else
6449             break;
6450     }
6451
6452     /* /c is not meaningful with s/// */
6453     if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
6454     {
6455         Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
6456     }
6457
6458     if (es) {
6459         SV *repl;
6460         PL_sublex_info.super_bufptr = s;
6461         PL_sublex_info.super_bufend = PL_bufend;
6462         PL_multi_end = 0;
6463         pm->op_pmflags |= PMf_EVAL;
6464         repl = newSVpvn("",0);
6465         while (es-- > 0)
6466             sv_catpv(repl, es ? "eval " : "do ");
6467         sv_catpvn(repl, "{ ", 2);
6468         sv_catsv(repl, PL_lex_repl);
6469         sv_catpvn(repl, " };", 2);
6470         SvEVALED_on(repl);
6471         SvREFCNT_dec(PL_lex_repl);
6472         PL_lex_repl = repl;
6473     }
6474
6475     pm->op_pmpermflags = pm->op_pmflags;
6476     PL_lex_op = (OP*)pm;
6477     yylval.ival = OP_SUBST;
6478     return s;
6479 }
6480
6481 STATIC char *
6482 S_scan_trans(pTHX_ char *start)
6483 {
6484     register char* s;
6485     OP *o;
6486     short *tbl;
6487     I32 squash;
6488     I32 del;
6489     I32 complement;
6490
6491     yylval.ival = OP_NULL;
6492
6493     s = scan_str(start,FALSE,FALSE);
6494     if (!s)
6495         Perl_croak(aTHX_ "Transliteration pattern not terminated");
6496     if (s[-1] == PL_multi_open)
6497         s--;
6498
6499     s = scan_str(s,FALSE,FALSE);
6500     if (!s) {
6501         if (PL_lex_stuff) {
6502             SvREFCNT_dec(PL_lex_stuff);
6503             PL_lex_stuff = Nullsv;
6504         }
6505         Perl_croak(aTHX_ "Transliteration replacement not terminated");
6506     }
6507
6508     complement = del = squash = 0;
6509     while (strchr("cds", *s)) {
6510         if (*s == 'c')
6511             complement = OPpTRANS_COMPLEMENT;
6512         else if (*s == 'd')
6513             del = OPpTRANS_DELETE;
6514         else if (*s == 's')
6515             squash = OPpTRANS_SQUASH;
6516         s++;
6517     }
6518
6519     New(803, tbl, complement&&!del?258:256, short);
6520     o = newPVOP(OP_TRANS, 0, (char*)tbl);
6521     o->op_private = del|squash|complement|
6522       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
6523       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);
6524
6525     PL_lex_op = o;
6526     yylval.ival = OP_TRANS;
6527     return s;
6528 }
6529
6530 STATIC char *
6531 S_scan_heredoc(pTHX_ register char *s)
6532 {
6533     SV *herewas;
6534     I32 op_type = OP_SCALAR;
6535     I32 len;
6536     SV *tmpstr;
6537     char term;
6538     register char *d;
6539     register char *e;
6540     char *peek;
6541     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
6542
6543     s += 2;
6544     d = PL_tokenbuf;
6545     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
6546     if (!outer)
6547         *d++ = '\n';
6548     for (peek = s; SPACE_OR_TAB(*peek); peek++) ;
6549     if (*peek && strchr("`'\"",*peek)) {
6550         s = peek;
6551         term = *s++;
6552         s = delimcpy(d, e, s, PL_bufend, term, &len);
6553         d += len;
6554         if (s < PL_bufend)
6555             s++;
6556     }
6557     else {
6558         if (*s == '\\')
6559             s++, term = '\'';
6560         else
6561             term = '"';
6562         if (!isALNUM_lazy_if(s,UTF))
6563             deprecate_old("bare << to mean <<\"\"");
6564         for (; isALNUM_lazy_if(s,UTF); s++) {
6565             if (d < e)
6566                 *d++ = *s;
6567         }
6568     }
6569     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
6570         Perl_croak(aTHX_ "Delimiter for here document is too long");
6571     *d++ = '\n';
6572     *d = '\0';
6573     len = d - PL_tokenbuf;
6574 #ifndef PERL_STRICT_CR
6575     d = strchr(s, '\r');
6576     if (d) {
6577         char *olds = s;
6578         s = d;
6579         while (s < PL_bufend) {
6580             if (*s == '\r') {
6581                 *d++ = '\n';
6582                 if (*++s == '\n')
6583                     s++;
6584             }
6585             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
6586                 *d++ = *s++;
6587                 s++;
6588             }
6589             else
6590                 *d++ = *s++;
6591         }
6592         *d = '\0';
6593         PL_bufend = d;
6594         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6595         s = olds;
6596     }
6597 #endif
6598     d = "\n";
6599     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
6600         herewas = newSVpvn(s,PL_bufend-s);
6601     else
6602         s--, herewas = newSVpvn(s,d-s);
6603     s += SvCUR(herewas);
6604
6605     tmpstr = NEWSV(87,79);
6606     sv_upgrade(tmpstr, SVt_PVIV);
6607     if (term == '\'') {
6608         op_type = OP_CONST;
6609         SvIVX(tmpstr) = -1;
6610     }
6611     else if (term == '`') {
6612         op_type = OP_BACKTICK;
6613         SvIVX(tmpstr) = '\\';
6614     }
6615
6616     CLINE;
6617     PL_multi_start = CopLINE(PL_curcop);
6618     PL_multi_open = PL_multi_close = '<';
6619     term = *PL_tokenbuf;
6620     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
6621         char *bufptr = PL_sublex_info.super_bufptr;
6622         char *bufend = PL_sublex_info.super_bufend;
6623         char *olds = s - SvCUR(herewas);
6624         s = strchr(bufptr, '\n');
6625         if (!s)
6626             s = bufend;
6627         d = s;
6628         while (s < bufend &&
6629           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6630             if (*s++ == '\n')
6631                 CopLINE_inc(PL_curcop);
6632         }
6633         if (s >= bufend) {
6634             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6635             missingterm(PL_tokenbuf);
6636         }
6637         sv_setpvn(herewas,bufptr,d-bufptr+1);
6638         sv_setpvn(tmpstr,d+1,s-d);
6639         s += len - 1;
6640         sv_catpvn(herewas,s,bufend-s);
6641         (void)strcpy(bufptr,SvPVX(herewas));
6642
6643         s = olds;
6644         goto retval;
6645     }
6646     else if (!outer) {
6647         d = s;
6648         while (s < PL_bufend &&
6649           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
6650             if (*s++ == '\n')
6651                 CopLINE_inc(PL_curcop);
6652         }
6653         if (s >= PL_bufend) {
6654             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6655             missingterm(PL_tokenbuf);
6656         }
6657         sv_setpvn(tmpstr,d+1,s-d);
6658         s += len - 1;
6659         CopLINE_inc(PL_curcop); /* the preceding stmt passes a newline */
6660
6661         sv_catpvn(herewas,s,PL_bufend-s);
6662         sv_setsv(PL_linestr,herewas);
6663         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
6664         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6665         PL_last_lop = PL_last_uni = Nullch;
6666     }
6667     else
6668         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
6669     while (s >= PL_bufend) {    /* multiple line string? */
6670         if (!outer ||
6671          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
6672             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
6673             missingterm(PL_tokenbuf);
6674         }
6675         CopLINE_inc(PL_curcop);
6676         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6677         PL_last_lop = PL_last_uni = Nullch;
6678 #ifndef PERL_STRICT_CR
6679         if (PL_bufend - PL_linestart >= 2) {
6680             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
6681                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
6682             {
6683                 PL_bufend[-2] = '\n';
6684                 PL_bufend--;
6685                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
6686             }
6687             else if (PL_bufend[-1] == '\r')
6688                 PL_bufend[-1] = '\n';
6689         }
6690         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
6691             PL_bufend[-1] = '\n';
6692 #endif
6693         if (PERLDB_LINE && PL_curstash != PL_debstash) {
6694             SV *sv = NEWSV(88,0);
6695
6696             sv_upgrade(sv, SVt_PVMG);
6697             sv_setsv(sv,PL_linestr);
6698             (void)SvIOK_on(sv);
6699             SvIVX(sv) = 0;
6700             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv);
6701         }
6702         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
6703             s = PL_bufend - 1;
6704             *s = ' ';
6705             sv_catsv(PL_linestr,herewas);
6706             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6707         }
6708         else {
6709             s = PL_bufend;
6710             sv_catsv(tmpstr,PL_linestr);
6711         }
6712     }
6713     s++;
6714 retval:
6715     PL_multi_end = CopLINE(PL_curcop);
6716     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
6717         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
6718         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
6719     }
6720     SvREFCNT_dec(herewas);
6721     if (!IN_BYTES) {
6722         if (UTF && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr)))
6723             SvUTF8_on(tmpstr);
6724         else if (PL_encoding)
6725             sv_recode_to_utf8(tmpstr, PL_encoding);
6726     }
6727     PL_lex_stuff = tmpstr;
6728     yylval.ival = op_type;
6729     return s;
6730 }
6731
6732 /* scan_inputsymbol
6733    takes: current position in input buffer
6734    returns: new position in input buffer
6735    side-effects: yylval and lex_op are set.
6736
6737    This code handles:
6738
6739    <>           read from ARGV
6740    <FH>         read from filehandle
6741    <pkg::FH>    read from package qualified filehandle
6742    <pkg'FH>     read from package qualified filehandle
6743    <$fh>        read from filehandle in $fh
6744    <*.h>        filename glob
6745
6746 */
6747
6748 STATIC char *
6749 S_scan_inputsymbol(pTHX_ char *start)
6750 {
6751     register char *s = start;           /* current position in buffer */
6752     register char *d;
6753     register char *e;
6754     char *end;
6755     I32 len;
6756
6757     d = PL_tokenbuf;                    /* start of temp holding space */
6758     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
6759     end = strchr(s, '\n');
6760     if (!end)
6761         end = PL_bufend;
6762     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
6763
6764     /* die if we didn't have space for the contents of the <>,
6765        or if it didn't end, or if we see a newline
6766     */
6767
6768     if (len >= sizeof PL_tokenbuf)
6769         Perl_croak(aTHX_ "Excessively long <> operator");
6770     if (s >= end)
6771         Perl_croak(aTHX_ "Unterminated <> operator");
6772
6773     s++;
6774
6775     /* check for <$fh>
6776        Remember, only scalar variables are interpreted as filehandles by
6777        this code.  Anything more complex (e.g., <$fh{$num}>) will be
6778        treated as a glob() call.
6779        This code makes use of the fact that except for the $ at the front,
6780        a scalar variable and a filehandle look the same.
6781     */
6782     if (*d == '$' && d[1]) d++;
6783
6784     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
6785     while (*d && (isALNUM_lazy_if(d,UTF) || *d == '\'' || *d == ':'))
6786         d++;
6787
6788     /* If we've tried to read what we allow filehandles to look like, and
6789        there's still text left, then it must be a glob() and not a getline.
6790        Use scan_str to pull out the stuff between the <> and treat it
6791        as nothing more than a string.
6792     */
6793
6794     if (d - PL_tokenbuf != len) {
6795         yylval.ival = OP_GLOB;
6796         set_csh();
6797         s = scan_str(start,FALSE,FALSE);
6798         if (!s)
6799            Perl_croak(aTHX_ "Glob not terminated");
6800         return s;
6801     }
6802     else {
6803         bool readline_overriden = FALSE;
6804         GV *gv_readline = Nullgv;
6805         GV **gvp;
6806         /* we're in a filehandle read situation */
6807         d = PL_tokenbuf;
6808
6809         /* turn <> into <ARGV> */
6810         if (!len)
6811             (void)strcpy(d,"ARGV");
6812
6813         /* Check whether readline() is overriden */
6814         if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV))
6815                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))
6816                 ||
6817                 ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE))
6818                 && (gv_readline = *gvp) != (GV*)&PL_sv_undef
6819                 && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)))
6820             readline_overriden = TRUE;
6821
6822         /* if <$fh>, create the ops to turn the variable into a
6823            filehandle
6824         */
6825         if (*d == '$') {
6826             I32 tmp;
6827
6828             /* try to find it in the pad for this block, otherwise find
6829                add symbol table ops
6830             */
6831             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
6832                 if (PAD_COMPNAME_FLAGS(tmp) & SVpad_OUR) {
6833                     SV *sym = sv_2mortal(
6834                             newSVpv(HvNAME(PAD_COMPNAME_OURSTASH(tmp)),0));
6835                     sv_catpvn(sym, "::", 2);
6836                     sv_catpv(sym, d+1);
6837                     d = SvPVX(sym);
6838                     goto intro_sym;
6839                 }
6840                 else {
6841                     OP *o = newOP(OP_PADSV, 0);
6842                     o->op_targ = tmp;
6843                     PL_lex_op = readline_overriden
6844                         ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6845                                 append_elem(OP_LIST, o,
6846                                     newCVREF(0, newGVOP(OP_GV,0,gv_readline))))
6847                         : (OP*)newUNOP(OP_READLINE, 0, o);
6848                 }
6849             }
6850             else {
6851                 GV *gv;
6852                 ++d;
6853 intro_sym:
6854                 gv = gv_fetchpv(d,
6855                                 (PL_in_eval
6856                                  ? (GV_ADDMULTI | GV_ADDINEVAL)
6857                                  : GV_ADDMULTI),
6858                                 SVt_PV);
6859                 PL_lex_op = readline_overriden
6860                     ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6861                             append_elem(OP_LIST,
6862                                 newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)),
6863                                 newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6864                     : (OP*)newUNOP(OP_READLINE, 0,
6865                             newUNOP(OP_RV2SV, 0,
6866                                 newGVOP(OP_GV, 0, gv)));
6867             }
6868             if (!readline_overriden)
6869                 PL_lex_op->op_flags |= OPf_SPECIAL;
6870             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
6871             yylval.ival = OP_NULL;
6872         }
6873
6874         /* If it's none of the above, it must be a literal filehandle
6875            (<Foo::BAR> or <FOO>) so build a simple readline OP */
6876         else {
6877             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
6878             PL_lex_op = readline_overriden
6879                 ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED,
6880                         append_elem(OP_LIST,
6881                             newGVOP(OP_GV, 0, gv),
6882                             newCVREF(0, newGVOP(OP_GV, 0, gv_readline))))
6883                 : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
6884             yylval.ival = OP_NULL;
6885         }
6886     }
6887
6888     return s;
6889 }
6890
6891
6892 /* scan_str
6893    takes: start position in buffer
6894           keep_quoted preserve \ on the embedded delimiter(s)
6895           keep_delims preserve the delimiters around the string
6896    returns: position to continue reading from buffer
6897    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
6898         updates the read buffer.
6899
6900    This subroutine pulls a string out of the input.  It is called for:
6901         q               single quotes           q(literal text)
6902         '               single quotes           'literal text'
6903         qq              double quotes           qq(interpolate $here please)
6904         "               double quotes           "interpolate $here please"
6905         qx              backticks               qx(/bin/ls -l)
6906         `               backticks               `/bin/ls -l`
6907         qw              quote words             @EXPORT_OK = qw( func() $spam )
6908         m//             regexp match            m/this/
6909         s///            regexp substitute       s/this/that/
6910         tr///           string transliterate    tr/this/that/
6911         y///            string transliterate    y/this/that/
6912         ($*@)           sub prototypes          sub foo ($)
6913         (stuff)         sub attr parameters     sub foo : attr(stuff)
6914         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
6915
6916    In most of these cases (all but <>, patterns and transliterate)
6917    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
6918    calls scan_str().  s/// makes yylex() call scan_subst() which calls
6919    scan_str().  tr/// and y/// make yylex() call scan_trans() which
6920    calls scan_str().
6921
6922    It skips whitespace before the string starts, and treats the first
6923    character as the delimiter.  If the delimiter is one of ([{< then
6924    the corresponding "close" character )]}> is used as the closing
6925    delimiter.  It allows quoting of delimiters, and if the string has
6926    balanced delimiters ([{<>}]) it allows nesting.
6927
6928    On success, the SV with the resulting string is put into lex_stuff or,
6929    if that is already non-NULL, into lex_repl. The second case occurs only
6930    when parsing the RHS of the special constructs s/// and tr/// (y///).
6931    For convenience, the terminating delimiter character is stuffed into
6932    SvIVX of the SV.
6933 */
6934
6935 STATIC char *
6936 S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims)
6937 {
6938     SV *sv;                             /* scalar value: string */
6939     char *tmps;                         /* temp string, used for delimiter matching */
6940     register char *s = start;           /* current position in the buffer */
6941     register char term;                 /* terminating character */
6942     register char *to;                  /* current position in the sv's data */
6943     I32 brackets = 1;                   /* bracket nesting level */
6944     bool has_utf8 = FALSE;              /* is there any utf8 content? */
6945     I32 termcode;                       /* terminating char. code */
6946     U8 termstr[UTF8_MAXLEN];            /* terminating string */
6947     STRLEN termlen;                     /* length of terminating string */
6948     char *last = NULL;                  /* last position for nesting bracket */
6949
6950     /* skip space before the delimiter */
6951     if (isSPACE(*s))
6952         s = skipspace(s);
6953
6954     /* mark where we are, in case we need to report errors */
6955     CLINE;
6956
6957     /* after skipping whitespace, the next character is the terminator */
6958     term = *s;
6959     if (!UTF) {
6960         termcode = termstr[0] = term;
6961         termlen = 1;
6962     }
6963     else {
6964         termcode = utf8_to_uvchr((U8*)s, &termlen);
6965         Copy(s, termstr, termlen, U8);
6966         if (!UTF8_IS_INVARIANT(term))
6967             has_utf8 = TRUE;
6968     }
6969
6970     /* mark where we are */
6971     PL_multi_start = CopLINE(PL_curcop);
6972     PL_multi_open = term;
6973
6974     /* find corresponding closing delimiter */
6975     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
6976         termcode = termstr[0] = term = tmps[5];
6977
6978     PL_multi_close = term;
6979
6980     /* create a new SV to hold the contents.  87 is leak category, I'm
6981        assuming.  79 is the SV's initial length.  What a random number. */
6982     sv = NEWSV(87,79);
6983     sv_upgrade(sv, SVt_PVIV);
6984     SvIVX(sv) = termcode;
6985     (void)SvPOK_only(sv);               /* validate pointer */
6986
6987     /* move past delimiter and try to read a complete string */
6988     if (keep_delims)
6989         sv_catpvn(sv, s, termlen);
6990     s += termlen;
6991     for (;;) {
6992         if (PL_encoding && !UTF) {
6993             bool cont = TRUE;
6994
6995             while (cont) {
6996                 int offset = s - SvPVX(PL_linestr);
6997                 bool found = sv_cat_decode(sv, PL_encoding, PL_linestr,
6998                                            &offset, (char*)termstr, termlen);
6999                 char *ns = SvPVX(PL_linestr) + offset;
7000                 char *svlast = SvEND(sv) - 1;
7001
7002                 for (; s < ns; s++) {
7003                     if (*s == '\n' && !PL_rsfp)
7004                         CopLINE_inc(PL_curcop);
7005                 }
7006                 if (!found)
7007                     goto read_more_line;
7008                 else {
7009                     /* handle quoted delimiters */
7010                     if (SvCUR(sv) > 1 && *(svlast-1) == '\\') {
7011                         char *t;
7012                         for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';)
7013                             t--;
7014                         if ((svlast-1 - t) % 2) {
7015                             if (!keep_quoted) {
7016                                 *(svlast-1) = term;
7017                                 *svlast = '\0';
7018                                 SvCUR_set(sv, SvCUR(sv) - 1);
7019                             }
7020                             continue;
7021                         }
7022                     }
7023                     if (PL_multi_open == PL_multi_close) {
7024                         cont = FALSE;
7025                     }
7026                     else {
7027                         char *t, *w;
7028                         if (!last)
7029                             last = SvPVX(sv);
7030                         for (w = t = last; t < svlast; w++, t++) {
7031                             /* At here, all closes are "was quoted" one,
7032                                so we don't check PL_multi_close. */
7033                             if (*t == '\\') {
7034                                 if (!keep_quoted && *(t+1) == PL_multi_open)
7035                                     t++;
7036                                 else
7037                                     *w++ = *t++;
7038                             }
7039                             else if (*t == PL_multi_open)
7040                                 brackets++;
7041
7042                             *w = *t;
7043                         }
7044                         if (w < t) {
7045                             *w++ = term;
7046                             *w = '\0';
7047                             SvCUR_set(sv, w - SvPVX(sv));
7048                         }
7049                         last = w;
7050                         if (--brackets <= 0)
7051                             cont = FALSE;
7052                     }
7053                 }
7054             }
7055             if (!keep_delims) {
7056                 SvCUR_set(sv, SvCUR(sv) - 1);
7057                 *SvEND(sv) = '\0';
7058             }
7059             break;
7060         }
7061
7062         /* extend sv if need be */
7063         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
7064         /* set 'to' to the next character in the sv's string */
7065         to = SvPVX(sv)+SvCUR(sv);
7066
7067         /* if open delimiter is the close delimiter read unbridle */
7068         if (PL_multi_open == PL_multi_close) {
7069             for (; s < PL_bufend; s++,to++) {
7070                 /* embedded newlines increment the current line number */
7071                 if (*s == '\n' && !PL_rsfp)
7072                     CopLINE_inc(PL_curcop);
7073                 /* handle quoted delimiters */
7074                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
7075                     if (!keep_quoted && s[1] == term)
7076                         s++;
7077                 /* any other quotes are simply copied straight through */
7078                     else
7079                         *to++ = *s++;
7080                 }
7081                 /* terminate when run out of buffer (the for() condition), or
7082                    have found the terminator */
7083                 else if (*s == term) {
7084                     if (termlen == 1)
7085                         break;
7086                     if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen))
7087                         break;
7088                 }
7089                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7090                     has_utf8 = TRUE;
7091                 *to = *s;
7092             }
7093         }
7094
7095         /* if the terminator isn't the same as the start character (e.g.,
7096            matched brackets), we have to allow more in the quoting, and
7097            be prepared for nested brackets.
7098         */
7099         else {
7100             /* read until we run out of string, or we find the terminator */
7101             for (; s < PL_bufend; s++,to++) {
7102                 /* embedded newlines increment the line count */
7103                 if (*s == '\n' && !PL_rsfp)
7104                     CopLINE_inc(PL_curcop);
7105                 /* backslashes can escape the open or closing characters */
7106                 if (*s == '\\' && s+1 < PL_bufend) {
7107                     if (!keep_quoted &&
7108                         ((s[1] == PL_multi_open) || (s[1] == PL_multi_close)))
7109                         s++;
7110                     else
7111                         *to++ = *s++;
7112                 }
7113                 /* allow nested opens and closes */
7114                 else if (*s == PL_multi_close && --brackets <= 0)
7115                     break;
7116                 else if (*s == PL_multi_open)
7117                     brackets++;
7118                 else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF)
7119                     has_utf8 = TRUE;
7120                 *to = *s;
7121             }
7122         }
7123         /* terminate the copied string and update the sv's end-of-string */
7124         *to = '\0';
7125         SvCUR_set(sv, to - SvPVX(sv));
7126
7127         /*
7128          * this next chunk reads more into the buffer if we're not done yet
7129          */
7130
7131         if (s < PL_bufend)
7132             break;              /* handle case where we are done yet :-) */
7133
7134 #ifndef PERL_STRICT_CR
7135         if (to - SvPVX(sv) >= 2) {
7136             if ((to[-2] == '\r' && to[-1] == '\n') ||
7137                 (to[-2] == '\n' && to[-1] == '\r'))
7138             {
7139                 to[-2] = '\n';
7140                 to--;
7141                 SvCUR_set(sv, to - SvPVX(sv));
7142             }
7143             else if (to[-1] == '\r')
7144                 to[-1] = '\n';
7145         }
7146         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
7147             to[-1] = '\n';
7148 #endif
7149
7150      read_more_line:
7151         /* if we're out of file, or a read fails, bail and reset the current
7152            line marker so we can report where the unterminated string began
7153         */
7154         if (!PL_rsfp ||
7155          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
7156             sv_free(sv);
7157             CopLINE_set(PL_curcop, (line_t)PL_multi_start);
7158             return Nullch;
7159         }
7160         /* we read a line, so increment our line counter */
7161         CopLINE_inc(PL_curcop);
7162
7163         /* update debugger info */
7164         if (PERLDB_LINE && PL_curstash != PL_debstash) {
7165             SV *sv = NEWSV(88,0);
7166
7167             sv_upgrade(sv, SVt_PVMG);
7168             sv_setsv(sv,PL_linestr);
7169             (void)SvIOK_on(sv);
7170             SvIVX(sv) = 0;
7171             av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv);
7172         }
7173
7174         /* having changed the buffer, we must update PL_bufend */
7175         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7176         PL_last_lop = PL_last_uni = Nullch;
7177     }
7178
7179     /* at this point, we have successfully read the delimited string */
7180
7181     if (!PL_encoding || UTF) {
7182         if (keep_delims)
7183             sv_catpvn(sv, s, termlen);
7184         s += termlen;
7185     }
7186     if (has_utf8 || PL_encoding)
7187         SvUTF8_on(sv);
7188
7189     PL_multi_end = CopLINE(PL_curcop);
7190
7191     /* if we allocated too much space, give some back */
7192     if (SvCUR(sv) + 5 < SvLEN(sv)) {
7193         SvLEN_set(sv, SvCUR(sv) + 1);
7194         Renew(SvPVX(sv), SvLEN(sv), char);
7195     }
7196
7197     /* decide whether this is the first or second quoted string we've read
7198        for this op
7199     */
7200
7201     if (PL_lex_stuff)
7202         PL_lex_repl = sv;
7203     else
7204         PL_lex_stuff = sv;
7205     return s;
7206 }
7207
7208 /*
7209   scan_num
7210   takes: pointer to position in buffer
7211   returns: pointer to new position in buffer
7212   side-effects: builds ops for the constant in yylval.op
7213
7214   Read a number in any of the formats that Perl accepts:
7215
7216   \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*)      12 12.34 12.
7217   \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*)                     .34
7218   0b[01](_?[01])*
7219   0[0-7](_?[0-7])*
7220   0x[0-9A-Fa-f](_?[0-9A-Fa-f])*
7221
7222   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
7223   thing it reads.
7224
7225   If it reads a number without a decimal point or an exponent, it will
7226   try converting the number to an integer and see if it can do so
7227   without loss of precision.
7228 */
7229
7230 char *
7231 Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp)
7232 {
7233     register char *s = start;           /* current position in buffer */
7234     register char *d;                   /* destination in temp buffer */
7235     register char *e;                   /* end of temp buffer */
7236     NV nv;                              /* number read, as a double */
7237     SV *sv = Nullsv;                    /* place to put the converted number */
7238     bool floatit;                       /* boolean: int or float? */
7239     char *lastub = 0;                   /* position of last underbar */
7240     static char number_too_long[] = "Number too long";
7241
7242     /* We use the first character to decide what type of number this is */
7243
7244     switch (*s) {
7245     default:
7246       Perl_croak(aTHX_ "panic: scan_num");
7247
7248     /* if it starts with a 0, it could be an octal number, a decimal in
7249        0.13 disguise, or a hexadecimal number, or a binary number. */
7250     case '0':
7251         {
7252           /* variables:
7253              u          holds the "number so far"
7254              shift      the power of 2 of the base
7255                         (hex == 4, octal == 3, binary == 1)
7256              overflowed was the number more than we can hold?
7257
7258              Shift is used when we add a digit.  It also serves as an "are
7259              we in octal/hex/binary?" indicator to disallow hex characters
7260              when in octal mode.
7261            */
7262             NV n = 0.0;
7263             UV u = 0;
7264             I32 shift;
7265             bool overflowed = FALSE;
7266             bool just_zero  = TRUE;     /* just plain 0 or binary number? */
7267             static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 };
7268             static char* bases[5] = { "", "binary", "", "octal",
7269                                       "hexadecimal" };
7270             static char* Bases[5] = { "", "Binary", "", "Octal",
7271                                       "Hexadecimal" };
7272             static char *maxima[5] = { "",
7273                                        "0b11111111111111111111111111111111",
7274                                        "",
7275                                        "037777777777",
7276                                        "0xffffffff" };
7277             char *base, *Base, *max;
7278
7279             /* check for hex */
7280             if (s[1] == 'x') {
7281                 shift = 4;
7282                 s += 2;
7283                 just_zero = FALSE;
7284             } else if (s[1] == 'b') {
7285                 shift = 1;
7286                 s += 2;
7287                 just_zero = FALSE;
7288             }
7289             /* check for a decimal in disguise */
7290             else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E')
7291                 goto decimal;
7292             /* so it must be octal */
7293             else {
7294                 shift = 3;
7295                 s++;
7296             }
7297
7298             if (*s == '_') {
7299                if (ckWARN(WARN_SYNTAX))
7300                    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7301                                "Misplaced _ in number");
7302                lastub = s++;
7303             }
7304
7305             base = bases[shift];
7306             Base = Bases[shift];
7307             max  = maxima[shift];
7308
7309             /* read the rest of the number */
7310             for (;;) {
7311                 /* x is used in the overflow test,
7312                    b is the digit we're adding on. */
7313                 UV x, b;
7314
7315                 switch (*s) {
7316
7317                 /* if we don't mention it, we're done */
7318                 default:
7319                     goto out;
7320
7321                 /* _ are ignored -- but warned about if consecutive */
7322                 case '_':
7323                     if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7324                         Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7325                                     "Misplaced _ in number");
7326                     lastub = s++;
7327                     break;
7328
7329                 /* 8 and 9 are not octal */
7330                 case '8': case '9':
7331                     if (shift == 3)
7332                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
7333                     /* FALL THROUGH */
7334
7335                 /* octal digits */
7336                 case '2': case '3': case '4':
7337                 case '5': case '6': case '7':
7338                     if (shift == 1)
7339                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
7340                     /* FALL THROUGH */
7341
7342                 case '0': case '1':
7343                     b = *s++ & 15;              /* ASCII digit -> value of digit */
7344                     goto digit;
7345
7346                 /* hex digits */
7347                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
7348                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
7349                     /* make sure they said 0x */
7350                     if (shift != 4)
7351                         goto out;
7352                     b = (*s++ & 7) + 9;
7353
7354                     /* Prepare to put the digit we have onto the end
7355                        of the number so far.  We check for overflows.
7356                     */
7357
7358                   digit:
7359                     just_zero = FALSE;
7360                     if (!overflowed) {
7361                         x = u << shift; /* make room for the digit */
7362
7363                         if ((x >> shift) != u
7364                             && !(PL_hints & HINT_NEW_BINARY)) {
7365                             overflowed = TRUE;
7366                             n = (NV) u;
7367                             if (ckWARN_d(WARN_OVERFLOW))
7368                                 Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
7369                                             "Integer overflow in %s number",
7370                                             base);
7371                         } else
7372                             u = x | b;          /* add the digit to the end */
7373                     }
7374                     if (overflowed) {
7375                         n *= nvshift[shift];
7376                         /* If an NV has not enough bits in its
7377                          * mantissa to represent an UV this summing of
7378                          * small low-order numbers is a waste of time
7379                          * (because the NV cannot preserve the
7380                          * low-order bits anyway): we could just
7381                          * remember when did we overflow and in the
7382                          * end just multiply n by the right
7383                          * amount. */
7384                         n += (NV) b;
7385                     }
7386                     break;
7387                 }
7388             }
7389
7390           /* if we get here, we had success: make a scalar value from
7391              the number.
7392           */
7393           out:
7394
7395             /* final misplaced underbar check */
7396             if (s[-1] == '_') {
7397                 if (ckWARN(WARN_SYNTAX))
7398                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7399             }
7400
7401             sv = NEWSV(92,0);
7402             if (overflowed) {
7403                 if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
7404                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7405                                 "%s number > %s non-portable",
7406                                 Base, max);
7407                 sv_setnv(sv, n);
7408             }
7409             else {
7410 #if UVSIZE > 4
7411                 if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
7412                     Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
7413                                 "%s number > %s non-portable",
7414                                 Base, max);
7415 #endif
7416                 sv_setuv(sv, u);
7417             }
7418             if (just_zero && (PL_hints & HINT_NEW_INTEGER))
7419                 sv = new_constant(start, s - start, "integer",
7420                                   sv, Nullsv, NULL);
7421             else if (PL_hints & HINT_NEW_BINARY)
7422                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
7423         }
7424         break;
7425
7426     /*
7427       handle decimal numbers.
7428       we're also sent here when we read a 0 as the first digit
7429     */
7430     case '1': case '2': case '3': case '4': case '5':
7431     case '6': case '7': case '8': case '9': case '.':
7432       decimal:
7433         d = PL_tokenbuf;
7434         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
7435         floatit = FALSE;
7436
7437         /* read next group of digits and _ and copy into d */
7438         while (isDIGIT(*s) || *s == '_') {
7439             /* skip underscores, checking for misplaced ones
7440                if -w is on
7441             */
7442             if (*s == '_') {
7443                 if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7444                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7445                                 "Misplaced _ in number");
7446                 lastub = s++;
7447             }
7448             else {
7449                 /* check for end of fixed-length buffer */
7450                 if (d >= e)
7451                     Perl_croak(aTHX_ number_too_long);
7452                 /* if we're ok, copy the character */
7453                 *d++ = *s++;
7454             }
7455         }
7456
7457         /* final misplaced underbar check */
7458         if (lastub && s == lastub + 1) {
7459             if (ckWARN(WARN_SYNTAX))
7460                 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Misplaced _ in number");
7461         }
7462
7463         /* read a decimal portion if there is one.  avoid
7464            3..5 being interpreted as the number 3. followed
7465            by .5
7466         */
7467         if (*s == '.' && s[1] != '.') {
7468             floatit = TRUE;
7469             *d++ = *s++;
7470
7471             if (*s == '_') {
7472                 if (ckWARN(WARN_SYNTAX))
7473                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7474                                 "Misplaced _ in number");
7475                 lastub = s;
7476             }
7477
7478             /* copy, ignoring underbars, until we run out of digits.
7479             */
7480             for (; isDIGIT(*s) || *s == '_'; s++) {
7481                 /* fixed length buffer check */
7482                 if (d >= e)
7483                     Perl_croak(aTHX_ number_too_long);
7484                 if (*s == '_') {
7485                    if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
7486                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7487                                    "Misplaced _ in number");
7488                    lastub = s;
7489                 }
7490                 else
7491                     *d++ = *s;
7492             }
7493             /* fractional part ending in underbar? */
7494             if (s[-1] == '_') {
7495                 if (ckWARN(WARN_SYNTAX))
7496                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7497                                 "Misplaced _ in number");
7498             }
7499             if (*s == '.' && isDIGIT(s[1])) {
7500                 /* oops, it's really a v-string, but without the "v" */
7501                 s = start;
7502                 goto vstring;
7503             }
7504         }
7505
7506         /* read exponent part, if present */
7507         if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) {
7508             floatit = TRUE;
7509             s++;
7510
7511             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
7512             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
7513
7514             /* stray preinitial _ */
7515             if (*s == '_') {
7516                 if (ckWARN(WARN_SYNTAX))
7517                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7518                                 "Misplaced _ in number");
7519                 lastub = s++;
7520             }
7521
7522             /* allow positive or negative exponent */
7523             if (*s == '+' || *s == '-')
7524                 *d++ = *s++;
7525
7526             /* stray initial _ */
7527             if (*s == '_') {
7528                 if (ckWARN(WARN_SYNTAX))
7529                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7530                                 "Misplaced _ in number");
7531                 lastub = s++;
7532             }
7533
7534             /* read digits of exponent */
7535             while (isDIGIT(*s) || *s == '_') {
7536                 if (isDIGIT(*s)) {
7537                     if (d >= e)
7538                         Perl_croak(aTHX_ number_too_long);
7539                     *d++ = *s++;
7540                 }
7541                 else {
7542                    if (ckWARN(WARN_SYNTAX) &&
7543                        ((lastub && s == lastub + 1) ||
7544                         (!isDIGIT(s[1]) && s[1] != '_')))
7545                        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
7546                                    "Misplaced _ in number");
7547                    lastub = s++;
7548                 }
7549             }
7550         }
7551
7552
7553         /* make an sv from the string */
7554         sv = NEWSV(92,0);
7555
7556         /*
7557            We try to do an integer conversion first if no characters
7558            indicating "float" have been found.
7559          */
7560
7561         if (!floatit) {
7562             UV uv;
7563             int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv);
7564
7565             if (flags == IS_NUMBER_IN_UV) {
7566               if (uv <= IV_MAX)
7567                 sv_setiv(sv, uv); /* Prefer IVs over UVs. */
7568               else
7569                 sv_setuv(sv, uv);
7570             } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) {
7571               if (uv <= (UV) IV_MIN)
7572                 sv_setiv(sv, -(IV)uv);
7573               else
7574                 floatit = TRUE;
7575             } else
7576               floatit = TRUE;
7577         }
7578         if (floatit) {
7579             /* terminate the string */
7580             *d = '\0';
7581             nv = Atof(PL_tokenbuf);
7582             sv_setnv(sv, nv);
7583         }
7584
7585         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
7586                        (PL_hints & HINT_NEW_INTEGER) )
7587             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
7588                               (floatit ? "float" : "integer"),
7589                               sv, Nullsv, NULL);
7590         break;
7591
7592     /* if it starts with a v, it could be a v-string */
7593     case 'v':
7594 vstring:
7595                 sv = NEWSV(92,5); /* preallocate storage space */
7596                 s = scan_vstring(s,sv);
7597         break;
7598     }
7599
7600     /* make the op for the constant and return */
7601
7602     if (sv)
7603         lvalp->opval = newSVOP(OP_CONST, 0, sv);
7604     else
7605         lvalp->opval = Nullop;
7606
7607     return s;
7608 }
7609
7610 STATIC char *
7611 S_scan_formline(pTHX_ register char *s)
7612 {
7613     register char *eol;
7614     register char *t;
7615     SV *stuff = newSVpvn("",0);
7616     bool needargs = FALSE;
7617     bool eofmt = FALSE;
7618
7619     while (!needargs) {
7620         if (*s == '.' || *s == /*{*/'}') {
7621             /*SUPPRESS 530*/
7622 #ifdef PERL_STRICT_CR
7623             for (t = s+1;SPACE_OR_TAB(*t); t++) ;
7624 #else
7625             for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ;
7626 #endif
7627             if (*t == '\n' || t == PL_bufend) {
7628                 eofmt = TRUE;
7629                 break;
7630             }
7631         }
7632         if (PL_in_eval && !PL_rsfp) {
7633             eol = strchr(s,'\n');
7634             if (!eol++)
7635                 eol = PL_bufend;
7636         }
7637         else
7638             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7639         if (*s != '#') {
7640             for (t = s; t < eol; t++) {
7641                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
7642                     needargs = FALSE;
7643                     goto enough;        /* ~~ must be first line in formline */
7644                 }
7645                 if (*t == '@' || *t == '^')
7646                     needargs = TRUE;
7647             }
7648             if (eol > s) {
7649                 sv_catpvn(stuff, s, eol-s);
7650 #ifndef PERL_STRICT_CR
7651                 if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') {
7652                     char *end = SvPVX(stuff) + SvCUR(stuff);
7653                     end[-2] = '\n';
7654                     end[-1] = '\0';
7655                     SvCUR(stuff)--;
7656                 }
7657 #endif
7658             }
7659             else
7660               break;
7661         }
7662         s = eol;
7663         if (PL_rsfp) {
7664             s = filter_gets(PL_linestr, PL_rsfp, 0);
7665             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
7666             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
7667             PL_last_lop = PL_last_uni = Nullch;
7668             if (!s) {
7669                 s = PL_bufptr;
7670                 break;
7671             }
7672         }
7673         incline(s);
7674     }
7675   enough:
7676     if (SvCUR(stuff)) {
7677         PL_expect = XTERM;
7678         if (needargs) {
7679             PL_lex_state = LEX_NORMAL;
7680             PL_nextval[PL_nexttoke].ival = 0;
7681             force_next(',');
7682         }
7683         else
7684             PL_lex_state = LEX_FORMLINE;
7685         if (!IN_BYTES) {
7686             if (UTF && is_utf8_string((U8*)SvPVX(stuff), SvCUR(stuff)))
7687                 SvUTF8_on(stuff);
7688             else if (PL_encoding)
7689                 sv_recode_to_utf8(stuff, PL_encoding);
7690         }
7691         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
7692         force_next(THING);
7693         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
7694         force_next(LSTOP);
7695     }
7696     else {
7697         SvREFCNT_dec(stuff);
7698         if (eofmt)
7699             PL_lex_formbrack = 0;
7700         PL_bufptr = s;
7701     }
7702     return s;
7703 }
7704
7705 STATIC void
7706 S_set_csh(pTHX)
7707 {
7708 #ifdef CSH
7709     if (!PL_cshlen)
7710         PL_cshlen = strlen(PL_cshname);
7711 #endif
7712 }
7713
7714 I32
7715 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
7716 {
7717     I32 oldsavestack_ix = PL_savestack_ix;
7718     CV* outsidecv = PL_compcv;
7719
7720     if (PL_compcv) {
7721         assert(SvTYPE(PL_compcv) == SVt_PVCV);
7722     }
7723     SAVEI32(PL_subline);
7724     save_item(PL_subname);
7725     SAVESPTR(PL_compcv);
7726
7727     PL_compcv = (CV*)NEWSV(1104,0);
7728     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
7729     CvFLAGS(PL_compcv) |= flags;
7730
7731     PL_subline = CopLINE(PL_curcop);
7732     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE|padnew_SAVESUB);
7733     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
7734     CvOUTSIDE_SEQ(PL_compcv) = PL_cop_seqmax;
7735
7736     return oldsavestack_ix;
7737 }
7738
7739 #ifdef __SC__
7740 #pragma segment Perl_yylex
7741 #endif
7742 int
7743 Perl_yywarn(pTHX_ char *s)
7744 {
7745     PL_in_eval |= EVAL_WARNONLY;
7746     yyerror(s);
7747     PL_in_eval &= ~EVAL_WARNONLY;
7748     return 0;
7749 }
7750
7751 int
7752 Perl_yyerror(pTHX_ char *s)
7753 {
7754     char *where = NULL;
7755     char *context = NULL;
7756     int contlen = -1;
7757     SV *msg;
7758
7759     if (!yychar || (yychar == ';' && !PL_rsfp))
7760         where = "at EOF";
7761     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
7762       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
7763         /*
7764                 Only for NetWare:
7765                 The code below is removed for NetWare because it abends/crashes on NetWare
7766                 when the script has error such as not having the closing quotes like:
7767                     if ($var eq "value)
7768                 Checking of white spaces is anyway done in NetWare code.
7769         */
7770 #ifndef NETWARE
7771         while (isSPACE(*PL_oldoldbufptr))
7772             PL_oldoldbufptr++;
7773 #endif
7774         context = PL_oldoldbufptr;
7775         contlen = PL_bufptr - PL_oldoldbufptr;
7776     }
7777     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
7778       PL_oldbufptr != PL_bufptr) {
7779         /*
7780                 Only for NetWare:
7781                 The code below is removed for NetWare because it abends/crashes on NetWare
7782                 when the script has error such as not having the closing quotes like:
7783                     if ($var eq "value)
7784                 Checking of white spaces is anyway done in NetWare code.
7785         */
7786 #ifndef NETWARE
7787         while (isSPACE(*PL_oldbufptr))
7788             PL_oldbufptr++;
7789 #endif
7790         context = PL_oldbufptr;
7791         contlen = PL_bufptr - PL_oldbufptr;
7792     }
7793     else if (yychar > 255)
7794         where = "next token ???";
7795 #ifdef USE_PURE_BISON
7796 /*  GNU Bison sets the value -2 */
7797     else if (yychar == -2) {
7798 #else
7799     else if ((yychar & 127) == 127) {
7800 #endif
7801         if (PL_lex_state == LEX_NORMAL ||
7802            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
7803             where = "at end of line";
7804         else if (PL_lex_inpat)
7805             where = "within pattern";
7806         else
7807             where = "within string";
7808     }
7809     else {
7810         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
7811         if (yychar < 32)
7812             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
7813         else if (isPRINT_LC(yychar))
7814             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
7815         else
7816             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
7817         where = SvPVX(where_sv);
7818     }
7819     msg = sv_2mortal(newSVpv(s, 0));
7820     Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ",
7821         OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
7822     if (context)
7823         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
7824     else
7825         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
7826     if (PL_multi_start < PL_multi_end && (U32)(CopLINE(PL_curcop) - PL_multi_end) <= 1) {
7827         Perl_sv_catpvf(aTHX_ msg,
7828         "  (Might be a runaway multi-line %c%c string starting on line %"IVdf")\n",
7829                 (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start);
7830         PL_multi_end = 0;
7831     }
7832     if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX))
7833         Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg);
7834     else
7835         qerror(msg);
7836     if (PL_error_count >= 10) {
7837         if (PL_in_eval && SvCUR(ERRSV))
7838             Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n",
7839             ERRSV, OutCopFILE(PL_curcop));
7840         else
7841             Perl_croak(aTHX_ "%s has too many errors.\n",
7842             OutCopFILE(PL_curcop));
7843     }
7844     PL_in_my = 0;
7845     PL_in_my_stash = Nullhv;
7846     return 0;
7847 }
7848 #ifdef __SC__
7849 #pragma segment Main
7850 #endif
7851
7852 STATIC char*
7853 S_swallow_bom(pTHX_ U8 *s)
7854 {
7855     STRLEN slen;
7856     slen = SvCUR(PL_linestr);
7857     switch (*s) {
7858     case 0xFF:
7859         if (s[1] == 0xFE) {
7860             /* UTF-16 little-endian */
7861             if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
7862                 Perl_croak(aTHX_ "Unsupported script encoding");
7863 #ifndef PERL_NO_UTF16_FILTER
7864             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
7865             s += 2;
7866             if (PL_bufend > (char*)s) {
7867                 U8 *news;
7868                 I32 newlen;
7869
7870                 filter_add(utf16rev_textfilter, NULL);
7871                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7872                 PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
7873                                                  PL_bufend - (char*)s - 1,
7874                                                  &newlen);
7875                 Copy(news, s, newlen, U8);
7876                 SvCUR_set(PL_linestr, newlen);
7877                 PL_bufend = SvPVX(PL_linestr) + newlen;
7878                 news[newlen++] = '\0';
7879                 Safefree(news);
7880             }
7881 #else
7882             Perl_croak(aTHX_ "Unsupported script encoding");
7883 #endif
7884         }
7885         break;
7886     case 0xFE:
7887         if (s[1] == 0xFF) {   /* UTF-16 big-endian */
7888 #ifndef PERL_NO_UTF16_FILTER
7889             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
7890             s += 2;
7891             if (PL_bufend > (char *)s) {
7892                 U8 *news;
7893                 I32 newlen;
7894
7895                 filter_add(utf16_textfilter, NULL);
7896                 New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
7897                 PL_bufend = (char*)utf16_to_utf8(s, news,
7898                                                  PL_bufend - (char*)s,
7899                                                  &newlen);
7900                 Copy(news, s, newlen, U8);
7901                 SvCUR_set(PL_linestr, newlen);
7902                 PL_bufend = SvPVX(PL_linestr) + newlen;
7903                 news[newlen++] = '\0';
7904                 Safefree(news);
7905             }
7906 #else
7907             Perl_croak(aTHX_ "Unsupported script encoding");
7908 #endif
7909         }
7910         break;
7911     case 0xEF:
7912         if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
7913             DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
7914             s += 3;                      /* UTF-8 */
7915         }
7916         break;
7917     case 0:
7918         if (slen > 3 && s[1] == 0 &&  /* UTF-32 big-endian */
7919             s[2] == 0xFE && s[3] == 0xFF)
7920         {
7921             Perl_croak(aTHX_ "Unsupported script encoding");
7922         }
7923     }
7924     return (char*)s;
7925 }
7926
7927 /*
7928  * restore_rsfp
7929  * Restore a source filter.
7930  */
7931
7932 static void
7933 restore_rsfp(pTHX_ void *f)
7934 {
7935     PerlIO *fp = (PerlIO*)f;
7936
7937     if (PL_rsfp == PerlIO_stdin())
7938         PerlIO_clearerr(PL_rsfp);
7939     else if (PL_rsfp && (PL_rsfp != fp))
7940         PerlIO_close(PL_rsfp);
7941     PL_rsfp = fp;
7942 }
7943
7944 #ifndef PERL_NO_UTF16_FILTER
7945 static I32
7946 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7947 {
7948     I32 count = FILTER_READ(idx+1, sv, maxlen);
7949     if (count) {
7950         U8* tmps;
7951         U8* tend;
7952         I32 newlen;
7953         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7954         if (!*SvPV_nolen(sv))
7955         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7956         return count;
7957
7958         tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7959         sv_usepvn(sv, (char*)tmps, tend - tmps);
7960     }
7961     return count;
7962 }
7963
7964 static I32
7965 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
7966 {
7967     I32 count = FILTER_READ(idx+1, sv, maxlen);
7968     if (count) {
7969         U8* tmps;
7970         U8* tend;
7971         I32 newlen;
7972         if (!*SvPV_nolen(sv))
7973         /* Game over, but don't feed an odd-length string to utf16_to_utf8 */
7974         return count;
7975
7976         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
7977         tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
7978         sv_usepvn(sv, (char*)tmps, tend - tmps);
7979     }
7980     return count;
7981 }
7982 #endif
7983
7984 /*
7985 Returns a pointer to the next character after the parsed
7986 vstring, as well as updating the passed in sv.
7987
7988 Function must be called like
7989
7990         sv = NEWSV(92,5);
7991         s = scan_vstring(s,sv);
7992
7993 The sv should already be large enough to store the vstring
7994 passed in, for performance reasons.
7995
7996 */
7997
7998 char *
7999 Perl_scan_vstring(pTHX_ char *s, SV *sv)
8000 {
8001     char *pos = s;
8002     char *start = s;
8003     if (*pos == 'v') pos++;  /* get past 'v' */
8004     while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
8005         pos++;
8006     if ( *pos != '.') {
8007         /* this may not be a v-string if followed by => */
8008         char *next = pos;
8009         while (next < PL_bufend && isSPACE(*next))
8010             ++next;
8011         if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) {
8012             /* return string not v-string */
8013             sv_setpvn(sv,(char *)s,pos-s);
8014             return pos;
8015         }
8016     }
8017
8018     if (!isALPHA(*pos)) {
8019         UV rev;
8020         U8 tmpbuf[UTF8_MAXLEN+1];
8021         U8 *tmpend;
8022
8023         if (*s == 'v') s++;  /* get past 'v' */
8024
8025         sv_setpvn(sv, "", 0);
8026
8027         for (;;) {
8028             rev = 0;
8029             {
8030                 /* this is atoi() that tolerates underscores */
8031                 char *end = pos;
8032                 UV mult = 1;
8033                 while (--end >= s) {
8034                     UV orev;
8035                     if (*end == '_')
8036                         continue;
8037                     orev = rev;
8038                     rev += (*end - '0') * mult;
8039                     mult *= 10;
8040                     if (orev > rev && ckWARN_d(WARN_OVERFLOW))
8041                         Perl_warner(aTHX_ packWARN(WARN_OVERFLOW),
8042                                     "Integer overflow in decimal number");
8043                 }
8044             }
8045 #ifdef EBCDIC
8046             if (rev > 0x7FFFFFFF)
8047                  Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647");
8048 #endif
8049             /* Append native character for the rev point */
8050             tmpend = uvchr_to_utf8(tmpbuf, rev);
8051             sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf);
8052             if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev)))
8053                  SvUTF8_on(sv);
8054             if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1]))
8055                  s = ++pos;
8056             else {
8057                  s = pos;
8058                  break;
8059             }
8060             while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_'))
8061                  pos++;
8062         }
8063         SvPOK_on(sv);
8064         sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start);
8065         SvRMAGICAL_on(sv);
8066     }
8067     return s;
8068 }
8069