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