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