toke.c

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