toke.c

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