toke.c

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