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 (ckWARN(WARN_DEPRECATED))
 216         warner(WARN_DEPRECATED, "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 && ckWARN(WARN_UTF8) && 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 (ckWARN(WARN_SYNTAX))
1009                     warner(WARN_SYNTAX, "\\%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 (ckWARN(WARN_UTF8) && !utf)
1051                         warner(WARN_UTF8,"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 - 1, &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 (ckWARN(WARN_UTF8) && uv >= 127 && UTF)
1066                             warner(WARN_UTF8,
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 (ckWARN(WARN_SEMICOLON) && isALPHA(*s) && PL_bufptr == PL_linestart) {
2473                 PL_curcop->cop_line--;
2474                 warner(WARN_SEMICOLON, 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 (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2507             warner(WARN_SYNTAX, "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 (ckWARN(WARN_SYNTAX)) {
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                         warner(WARN_SYNTAX,
2646                                 "Multidimensional syntax %.*s not supported",
2647                                 (t - PL_bufptr) + 1, PL_bufptr);
2648                     }
2649                 }
2650             }
2651             else if (*s == '{') {
2652                 PL_tokenbuf[0] = '%';
2653                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2654                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
2655                 {
2656                     char tmpbuf[sizeof PL_tokenbuf];
2657                     STRLEN len;
2658                     for (t++; isSPACE(*t); t++) ;
2659                     if (isIDFIRST(*t)) {
2660                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2661                         if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
2662                             warner(WARN_SYNTAX,
2663                                 "You need to quote \"%s\"", tmpbuf);
2664                     }
2665                 }
2666             }
2667         }
2668
2669         PL_expect = XOPERATOR;
2670         if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2671             bool islop = (PL_last_lop == PL_oldoldbufptr);
2672             if (!islop || PL_last_lop_op == OP_GREPSTART)
2673                 PL_expect = XOPERATOR;
2674             else if (strchr("$@\"'`q", *s))
2675                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
2676             else if (strchr("&*<%", *s) && isIDFIRST(s[1]))
2677                 PL_expect = XTERM;              /* e.g. print $fh &sub */
2678             else if (isIDFIRST(*s)) {
2679                 char tmpbuf[sizeof PL_tokenbuf];
2680                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2681                 if (tmp = keyword(tmpbuf, len)) {
2682                     /* binary operators exclude handle interpretations */
2683                     switch (tmp) {
2684                     case -KEY_x:
2685                     case -KEY_eq:
2686                     case -KEY_ne:
2687                     case -KEY_gt:
2688                     case -KEY_lt:
2689                     case -KEY_ge:
2690                     case -KEY_le:
2691                     case -KEY_cmp:
2692                         break;
2693                     default:
2694                         PL_expect = XTERM;      /* e.g. print $fh length() */
2695                         break;
2696                     }
2697                 }
2698                 else {
2699                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2700                     if (gv && GvCVu(gv))
2701                         PL_expect = XTERM;      /* e.g. print $fh subr() */
2702                 }
2703             }
2704             else if (isDIGIT(*s))
2705                 PL_expect = XTERM;              /* e.g. print $fh 3 */
2706             else if (*s == '.' && isDIGIT(s[1]))
2707                 PL_expect = XTERM;              /* e.g. print $fh .3 */
2708             else if (strchr("/?-+", *s) && !isSPACE(s[1]))
2709                 PL_expect = XTERM;              /* e.g. print $fh -1 */
2710             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
2711                 PL_expect = XTERM;              /* print $fh <<"EOF" */
2712         }
2713         PL_pending_ident = '$';
2714         TOKEN('$');
2715
2716     case '@':
2717         if (PL_expect == XOPERATOR)
2718             no_op("Array", s);
2719         PL_tokenbuf[0] = '@';
2720         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2721         if (!PL_tokenbuf[1]) {
2722             if (s == PL_bufend)
2723                 yyerror("Final @ should be \\@ or @name");
2724             PREREF('@');
2725         }
2726         if (PL_lex_state == LEX_NORMAL)
2727             s = skipspace(s);
2728         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2729             if (*s == '{')
2730                 PL_tokenbuf[0] = '%';
2731
2732             /* Warn about @ where they meant $. */
2733             if (ckWARN(WARN_SYNTAX)) {
2734                 if (*s == '[' || *s == '{') {
2735                     char *t = s + 1;
2736                     while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
2737                         t++;
2738                     if (*t == '}' || *t == ']') {
2739                         t++;
2740                         PL_bufptr = skipspace(PL_bufptr);
2741                         warner(WARN_SYNTAX,
2742                             "Scalar value %.*s better written as $%.*s",
2743                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2744                     }
2745                 }
2746             }
2747         }
2748         PL_pending_ident = '@';
2749         TERM('@');
2750
2751     case '/':                   /* may either be division or pattern */
2752     case '?':                   /* may either be conditional or pattern */
2753         if (PL_expect != XOPERATOR) {
2754             /* Disable warning on "study /blah/" */
2755             if (PL_oldoldbufptr == PL_last_uni
2756                 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2757                     || memNE(PL_last_uni, "study", 5) || isALNUM(PL_last_uni[5])))
2758                 check_uni();
2759             s = scan_pat(s,OP_MATCH);
2760             TERM(sublex_start());
2761         }
2762         tmp = *s++;
2763         if (tmp == '/')
2764             Mop(OP_DIVIDE);
2765         OPERATOR(tmp);
2766
2767     case '.':
2768         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack && s[1] == '\n' &&
2769                 (s == PL_linestart || s[-1] == '\n') ) {
2770             PL_lex_formbrack = 0;
2771             PL_expect = XSTATE;
2772             goto rightbracket;
2773         }
2774         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2775             tmp = *s++;
2776             if (*s == tmp) {
2777                 s++;
2778                 if (*s == tmp) {
2779                     s++;
2780                     yylval.ival = OPf_SPECIAL;
2781                 }
2782                 else
2783                     yylval.ival = 0;
2784                 OPERATOR(DOTDOT);
2785             }
2786             if (PL_expect != XOPERATOR)
2787                 check_uni();
2788             Aop(OP_CONCAT);
2789         }
2790         /* FALL THROUGH */
2791     case '0': case '1': case '2': case '3': case '4':
2792     case '5': case '6': case '7': case '8': case '9':
2793         s = scan_num(s);
2794         if (PL_expect == XOPERATOR)
2795             no_op("Number",s);
2796         TERM(THING);
2797
2798     case '\'':
2799         s = scan_str(s);
2800         if (PL_expect == XOPERATOR) {
2801             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2802                 PL_expect = XTERM;
2803                 depcom();
2804                 return ',';     /* grandfather non-comma-format format */
2805             }
2806             else
2807                 no_op("String",s);
2808         }
2809         if (!s)
2810             missingterm((char*)0);
2811         yylval.ival = OP_CONST;
2812         TERM(sublex_start());
2813
2814     case '"':
2815         s = scan_str(s);
2816         if (PL_expect == XOPERATOR) {
2817             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2818                 PL_expect = XTERM;
2819                 depcom();
2820                 return ',';     /* grandfather non-comma-format format */
2821             }
2822             else
2823                 no_op("String",s);
2824         }
2825         if (!s)
2826             missingterm((char*)0);
2827         yylval.ival = OP_CONST;
2828         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2829             if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2830                 yylval.ival = OP_STRINGIFY;
2831                 break;
2832             }
2833         }
2834         TERM(sublex_start());
2835
2836     case '`':
2837         s = scan_str(s);
2838         if (PL_expect == XOPERATOR)
2839             no_op("Backticks",s);
2840         if (!s)
2841             missingterm((char*)0);
2842         yylval.ival = OP_BACKTICK;
2843         set_csh();
2844         TERM(sublex_start());
2845
2846     case '\\':
2847         s++;
2848         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2849             warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2850                         *s, *s);
2851         if (PL_expect == XOPERATOR)
2852             no_op("Backslash",s);
2853         OPERATOR(REFGEN);
2854
2855     case 'x':
2856         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2857             s++;
2858             Mop(OP_REPEAT);
2859         }
2860         goto keylookup;
2861
2862     case '_':
2863     case 'a': case 'A':
2864     case 'b': case 'B':
2865     case 'c': case 'C':
2866     case 'd': case 'D':
2867     case 'e': case 'E':
2868     case 'f': case 'F':
2869     case 'g': case 'G':
2870     case 'h': case 'H':
2871     case 'i': case 'I':
2872     case 'j': case 'J':
2873     case 'k': case 'K':
2874     case 'l': case 'L':
2875     case 'm': case 'M':
2876     case 'n': case 'N':
2877     case 'o': case 'O':
2878     case 'p': case 'P':
2879     case 'q': case 'Q':
2880     case 'r': case 'R':
2881     case 's': case 'S':
2882     case 't': case 'T':
2883     case 'u': case 'U':
2884     case 'v': case 'V':
2885     case 'w': case 'W':
2886               case 'X':
2887     case 'y': case 'Y':
2888     case 'z': case 'Z':
2889
2890       keylookup: {
2891         gv = Nullgv;
2892         gvp = 0;
2893
2894         PL_bufptr = s;
2895         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2896
2897         /* Some keywords can be followed by any delimiter, including ':' */
2898         tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2899                len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2900                             (PL_tokenbuf[0] == 'q' &&
2901                              strchr("qwxr", PL_tokenbuf[1]))));
2902
2903         /* x::* is just a word, unless x is "CORE" */
2904         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2905             goto just_a_word;
2906
2907         d = s;
2908         while (d < PL_bufend && isSPACE(*d))
2909                 d++;    /* no comments skipped here, or s### is misparsed */
2910
2911         /* Is this a label? */
2912         if (!tmp && PL_expect == XSTATE
2913               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2914             s = d + 1;
2915             yylval.pval = savepv(PL_tokenbuf);
2916             CLINE;
2917             TOKEN(LABEL);
2918         }
2919
2920         /* Check for keywords */
2921         tmp = keyword(PL_tokenbuf, len);
2922
2923         /* Is this a word before a => operator? */
2924         if (strnEQ(d,"=>",2)) {
2925             CLINE;
2926             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
2927             yylval.opval->op_private = OPpCONST_BARE;
2928             TERM(WORD);
2929         }
2930
2931         if (tmp < 0) {                  /* second-class keyword? */
2932             GV *ogv = Nullgv;   /* override (winner) */
2933             GV *hgv = Nullgv;   /* hidden (loser) */
2934             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
2935                 CV *cv;
2936                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
2937                     (cv = GvCVu(gv)))
2938                 {
2939                     if (GvIMPORTED_CV(gv))
2940                         ogv = gv;
2941                     else if (! CvMETHOD(cv))
2942                         hgv = gv;
2943                 }
2944                 if (!ogv &&
2945                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
2946                     (gv = *gvp) != (GV*)&PL_sv_undef &&
2947                     GvCVu(gv) && GvIMPORTED_CV(gv))
2948                 {
2949                     ogv = gv;
2950                 }
2951             }
2952             if (ogv) {
2953                 tmp = 0;                /* overridden by import or by GLOBAL */
2954             }
2955             else if (gv && !gvp
2956                      && -tmp==KEY_lock  /* XXX generalizable kludge */
2957                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
2958             {
2959                 tmp = 0;                /* any sub overrides "weak" keyword */
2960             }
2961             else {                      /* no override */
2962                 tmp = -tmp;
2963                 gv = Nullgv;
2964                 gvp = 0;
2965                 if (ckWARN(WARN_AMBIGUOUS) && hgv)
2966                     warner(WARN_AMBIGUOUS,
2967                         "Ambiguous call resolved as CORE::%s(), %s",
2968                          GvENAME(hgv), "qualify as such or use &");
2969             }
2970         }
2971
2972       reserved_word:
2973         switch (tmp) {
2974
2975         default:                        /* not a keyword */
2976           just_a_word: {
2977                 SV *sv;
2978                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
2979
2980                 /* Get the rest if it looks like a package qualifier */
2981
2982                 if (*s == '\'' || *s == ':' && s[1] == ':') {
2983                     STRLEN morelen;
2984                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
2985                                   TRUE, &morelen);
2986                     if (!morelen)
2987                         croak("Bad name after %s%s", PL_tokenbuf,
2988                                 *s == '\'' ? "'" : "::");
2989                     len += morelen;
2990                 }
2991
2992                 if (PL_expect == XOPERATOR) {
2993                     if (PL_bufptr == PL_linestart) {
2994                         PL_curcop->cop_line--;
2995                         warner(WARN_SEMICOLON, warn_nosemi);
2996                         PL_curcop->cop_line++;
2997                     }
2998                     else
2999                         no_op("Bareword",s);
3000                 }
3001
3002                 /* Look for a subroutine with this name in current package,
3003                    unless name is "Foo::", in which case Foo is a bearword
3004                    (and a package name). */
3005
3006                 if (len > 2 &&
3007                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3008                 {
3009                     if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3010                         warner(WARN_UNSAFE,
3011                             "Bareword \"%s\" refers to nonexistent package",
3012                              PL_tokenbuf);
3013                     len -= 2;
3014                     PL_tokenbuf[len] = '\0';
3015                     gv = Nullgv;
3016                     gvp = 0;
3017                 }
3018                 else {
3019                     len = 0;
3020                     if (!gv)
3021                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3022                 }
3023
3024                 /* if we saw a global override before, get the right name */
3025
3026                 if (gvp) {
3027                     sv = newSVpv("CORE::GLOBAL::",14);
3028                     sv_catpv(sv,PL_tokenbuf);
3029                 }
3030                 else
3031                     sv = newSVpv(PL_tokenbuf,0);
3032
3033                 /* Presume this is going to be a bareword of some sort. */
3034
3035                 CLINE;
3036                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3037                 yylval.opval->op_private = OPpCONST_BARE;
3038
3039                 /* And if "Foo::", then that's what it certainly is. */
3040
3041                 if (len)
3042                     goto safe_bareword;
3043
3044                 /* See if it's the indirect object for a list operator. */
3045
3046                 if (PL_oldoldbufptr &&
3047                     PL_oldoldbufptr < PL_bufptr &&
3048                     (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3049                     /* NO SKIPSPACE BEFORE HERE! */
3050                     (PL_expect == XREF
3051                      || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3052                      || (PL_last_lop_op == OP_ENTERSUB
3053                          && PL_last_proto
3054                          && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3055                 {
3056                     bool immediate_paren = *s == '(';
3057
3058                     /* (Now we can afford to cross potential line boundary.) */
3059                     s = skipspace(s);
3060
3061                     /* Two barewords in a row may indicate method call. */
3062
3063                     if ((isALPHA(*s) || *s == '$') && (tmp=intuit_method(s,gv)))
3064                         return tmp;
3065
3066                     /* If not a declared subroutine, it's an indirect object. */
3067                     /* (But it's an indir obj regardless for sort.) */
3068
3069                     if ((PL_last_lop_op == OP_SORT ||
3070                          (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3071                         (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3072                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3073                         goto bareword;
3074                     }
3075                 }
3076
3077                 /* If followed by a paren, it's certainly a subroutine. */
3078
3079                 PL_expect = XOPERATOR;
3080                 s = skipspace(s);
3081                 if (*s == '(') {
3082                     CLINE;
3083                     if (gv && GvCVu(gv)) {
3084                         for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3085                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3086                             s = d + 1;
3087                             goto its_constant;
3088                         }
3089                     }
3090                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3091                     PL_expect = XOPERATOR;
3092                     force_next(WORD);
3093                     yylval.ival = 0;
3094                     TOKEN('&');
3095                 }
3096
3097                 /* If followed by var or block, call it a method (unless sub) */
3098
3099                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3100                     PL_last_lop = PL_oldbufptr;
3101                     PL_last_lop_op = OP_METHOD;
3102                     PREBLOCK(METHOD);
3103                 }
3104
3105                 /* If followed by a bareword, see if it looks like indir obj. */
3106
3107                 if ((isALPHA(*s) || *s == '$') && (tmp = intuit_method(s,gv)))
3108                     return tmp;
3109
3110                 /* Not a method, so call it a subroutine (if defined) */
3111
3112                 if (gv && GvCVu(gv)) {
3113                     CV* cv;
3114                     if (lastchar == '-')
3115                         warn("Ambiguous use of -%s resolved as -&%s()",
3116                                 PL_tokenbuf, PL_tokenbuf);
3117                     PL_last_lop = PL_oldbufptr;
3118                     PL_last_lop_op = OP_ENTERSUB;
3119                     /* Check for a constant sub */
3120                     cv = GvCV(gv);
3121                     if ((sv = cv_const_sv(cv))) {
3122                   its_constant:
3123                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3124                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3125                         yylval.opval->op_private = 0;
3126                         TOKEN(WORD);
3127                     }
3128
3129                     /* Resolve to GV now. */
3130                     op_free(yylval.opval);
3131                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3132                     /* Is there a prototype? */
3133                     if (SvPOK(cv)) {
3134                         STRLEN len;
3135                         PL_last_proto = SvPV((SV*)cv, len);
3136                         if (!len)
3137                             TERM(FUNC0SUB);
3138                         if (strEQ(PL_last_proto, "$"))
3139                             OPERATOR(UNIOPSUB);
3140                         if (*PL_last_proto == '&' && *s == '{') {
3141                             sv_setpv(PL_subname,"__ANON__");
3142                             PREBLOCK(LSTOPSUB);
3143                         }
3144                     } else
3145                         PL_last_proto = NULL;
3146                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3147                     PL_expect = XTERM;
3148                     force_next(WORD);
3149                     TOKEN(NOAMP);
3150                 }
3151
3152                 if (PL_hints & HINT_STRICT_SUBS &&
3153                     lastchar != '-' &&
3154                     strnNE(s,"->",2) &&
3155                     PL_last_lop_op != OP_TRUNCATE &&  /* S/F prototype in opcode.pl */
3156                     PL_last_lop_op != OP_ACCEPT &&
3157                     PL_last_lop_op != OP_PIPE_OP &&
3158                     PL_last_lop_op != OP_SOCKPAIR)
3159                 {
3160                     warn(
3161                      "Bareword \"%s\" not allowed while \"strict subs\" in use",
3162                         PL_tokenbuf);
3163                     ++PL_error_count;
3164                 }
3165
3166                 /* Call it a bare word */
3167
3168             bareword:
3169                 if (ckWARN(WARN_RESERVED)) {
3170                     if (lastchar != '-') {
3171                         for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3172                         if (!*d)
3173                             warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
3174                     }
3175                 }
3176
3177             safe_bareword:
3178                 if (lastchar && strchr("*%&", lastchar)) {
3179                     warn("Operator or semicolon missing before %c%s",
3180                         lastchar, PL_tokenbuf);
3181                     warn("Ambiguous use of %c resolved as operator %c",
3182                         lastchar, lastchar);
3183                 }
3184                 TOKEN(WORD);
3185             }
3186
3187         case KEY___FILE__:
3188             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3189                                         newSVsv(GvSV(PL_curcop->cop_filegv)));
3190             TERM(THING);
3191
3192         case KEY___LINE__:
3193             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3194                                     newSVpvf("%ld", (long)PL_curcop->cop_line));
3195             TERM(THING);
3196
3197         case KEY___PACKAGE__:
3198             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3199                                         (PL_curstash
3200                                          ? newSVsv(PL_curstname)
3201                                          : &PL_sv_undef));
3202             TERM(THING);
3203
3204         case KEY___DATA__:
3205         case KEY___END__: {
3206             GV *gv;
3207
3208             /*SUPPRESS 560*/
3209             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3210                 char *pname = "main";
3211                 if (PL_tokenbuf[2] == 'D')
3212                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3213                 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3214                 GvMULTI_on(gv);
3215                 if (!GvIO(gv))
3216                     GvIOp(gv) = newIO();
3217                 IoIFP(GvIOp(gv)) = PL_rsfp;
3218 #if defined(HAS_FCNTL) && defined(F_SETFD)
3219                 {
3220                     int fd = PerlIO_fileno(PL_rsfp);
3221                     fcntl(fd,F_SETFD,fd >= 3);
3222                 }
3223 #endif
3224                 /* Mark this internal pseudo-handle as clean */
3225                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3226                 if (PL_preprocess)
3227                     IoTYPE(GvIOp(gv)) = '|';
3228                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3229                     IoTYPE(GvIOp(gv)) = '-';
3230                 else
3231                     IoTYPE(GvIOp(gv)) = '<';
3232                 PL_rsfp = Nullfp;
3233             }
3234             goto fake_eof;
3235         }
3236
3237         case KEY_AUTOLOAD:
3238         case KEY_DESTROY:
3239         case KEY_BEGIN:
3240         case KEY_END:
3241         case KEY_INIT:
3242             if (PL_expect == XSTATE) {
3243                 s = PL_bufptr;
3244                 goto really_sub;
3245             }
3246             goto just_a_word;
3247
3248         case KEY_CORE:
3249             if (*s == ':' && s[1] == ':') {
3250                 s += 2;
3251                 d = s;
3252                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3253                 tmp = keyword(PL_tokenbuf, len);
3254                 if (tmp < 0)
3255                     tmp = -tmp;
3256                 goto reserved_word;
3257             }
3258             goto just_a_word;
3259
3260         case KEY_abs:
3261             UNI(OP_ABS);
3262
3263         case KEY_alarm:
3264             UNI(OP_ALARM);
3265
3266         case KEY_accept:
3267             LOP(OP_ACCEPT,XTERM);
3268
3269         case KEY_and:
3270             OPERATOR(ANDOP);
3271
3272         case KEY_atan2:
3273             LOP(OP_ATAN2,XTERM);
3274
3275         case KEY_bind:
3276             LOP(OP_BIND,XTERM);
3277
3278         case KEY_binmode:
3279             UNI(OP_BINMODE);
3280
3281         case KEY_bless:
3282             LOP(OP_BLESS,XTERM);
3283
3284         case KEY_chop:
3285             UNI(OP_CHOP);
3286
3287         case KEY_continue:
3288             PREBLOCK(CONTINUE);
3289
3290         case KEY_chdir:
3291             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
3292             UNI(OP_CHDIR);
3293
3294         case KEY_close:
3295             UNI(OP_CLOSE);
3296
3297         case KEY_closedir:
3298             UNI(OP_CLOSEDIR);
3299
3300         case KEY_cmp:
3301             Eop(OP_SCMP);
3302
3303         case KEY_caller:
3304             UNI(OP_CALLER);
3305
3306         case KEY_crypt:
3307 #ifdef FCRYPT
3308             if (!PL_cryptseen++)
3309                 init_des();
3310 #endif
3311             LOP(OP_CRYPT,XTERM);
3312
3313         case KEY_chmod:
3314             if (ckWARN(WARN_OCTAL)) {
3315                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3316                 if (*d != '0' && isDIGIT(*d))
3317                     yywarn("chmod: mode argument is missing initial 0");
3318             }
3319             LOP(OP_CHMOD,XTERM);
3320
3321         case KEY_chown:
3322             LOP(OP_CHOWN,XTERM);
3323
3324         case KEY_connect:
3325             LOP(OP_CONNECT,XTERM);
3326
3327         case KEY_chr:
3328             UNI(OP_CHR);
3329
3330         case KEY_cos:
3331             UNI(OP_COS);
3332
3333         case KEY_chroot:
3334             UNI(OP_CHROOT);
3335
3336         case KEY_do:
3337             s = skipspace(s);
3338             if (*s == '{')
3339                 PRETERMBLOCK(DO);
3340             if (*s != '\'')
3341                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3342             OPERATOR(DO);
3343
3344         case KEY_die:
3345             PL_hints |= HINT_BLOCK_SCOPE;
3346             LOP(OP_DIE,XTERM);
3347
3348         case KEY_defined:
3349             UNI(OP_DEFINED);
3350
3351         case KEY_delete:
3352             UNI(OP_DELETE);
3353
3354         case KEY_dbmopen:
3355             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3356             LOP(OP_DBMOPEN,XTERM);
3357
3358         case KEY_dbmclose:
3359             UNI(OP_DBMCLOSE);
3360
3361         case KEY_dump:
3362             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3363             LOOPX(OP_DUMP);
3364
3365         case KEY_else:
3366             PREBLOCK(ELSE);
3367
3368         case KEY_elsif:
3369             yylval.ival = PL_curcop->cop_line;
3370             OPERATOR(ELSIF);
3371
3372         case KEY_eq:
3373             Eop(OP_SEQ);
3374
3375         case KEY_exists:
3376             UNI(OP_EXISTS);
3377
3378         case KEY_exit:
3379             UNI(OP_EXIT);
3380
3381         case KEY_eval:
3382             s = skipspace(s);
3383             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3384             UNIBRACK(OP_ENTEREVAL);
3385
3386         case KEY_eof:
3387             UNI(OP_EOF);
3388
3389         case KEY_exp:
3390             UNI(OP_EXP);
3391
3392         case KEY_each:
3393             UNI(OP_EACH);
3394
3395         case KEY_exec:
3396             set_csh();
3397             LOP(OP_EXEC,XREF);
3398
3399         case KEY_endhostent:
3400             FUN0(OP_EHOSTENT);
3401
3402         case KEY_endnetent:
3403             FUN0(OP_ENETENT);
3404
3405         case KEY_endservent:
3406             FUN0(OP_ESERVENT);
3407
3408         case KEY_endprotoent:
3409             FUN0(OP_EPROTOENT);
3410
3411         case KEY_endpwent:
3412             FUN0(OP_EPWENT);
3413
3414         case KEY_endgrent:
3415             FUN0(OP_EGRENT);
3416
3417         case KEY_for:
3418         case KEY_foreach:
3419             yylval.ival = PL_curcop->cop_line;
3420             s = skipspace(s);
3421             if (PL_expect == XSTATE && isIDFIRST(*s)) {
3422                 char *p = s;
3423                 if ((PL_bufend - p) >= 3 &&
3424                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3425                     p += 2;
3426                 p = skipspace(p);
3427                 if (isIDFIRST(*p))
3428                     croak("Missing $ on loop variable");
3429             }
3430             OPERATOR(FOR);
3431
3432         case KEY_formline:
3433             LOP(OP_FORMLINE,XTERM);
3434
3435         case KEY_fork:
3436             FUN0(OP_FORK);
3437
3438         case KEY_fcntl:
3439             LOP(OP_FCNTL,XTERM);
3440
3441         case KEY_fileno:
3442             UNI(OP_FILENO);
3443
3444         case KEY_flock:
3445             LOP(OP_FLOCK,XTERM);
3446
3447         case KEY_gt:
3448             Rop(OP_SGT);
3449
3450         case KEY_ge:
3451             Rop(OP_SGE);
3452
3453         case KEY_grep:
3454             LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3455
3456         case KEY_goto:
3457             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3458             LOOPX(OP_GOTO);
3459
3460         case KEY_gmtime:
3461             UNI(OP_GMTIME);
3462
3463         case KEY_getc:
3464             UNI(OP_GETC);
3465
3466         case KEY_getppid:
3467             FUN0(OP_GETPPID);
3468
3469         case KEY_getpgrp:
3470             UNI(OP_GETPGRP);
3471
3472         case KEY_getpriority:
3473             LOP(OP_GETPRIORITY,XTERM);
3474
3475         case KEY_getprotobyname:
3476             UNI(OP_GPBYNAME);
3477
3478         case KEY_getprotobynumber:
3479             LOP(OP_GPBYNUMBER,XTERM);
3480
3481         case KEY_getprotoent:
3482             FUN0(OP_GPROTOENT);
3483
3484         case KEY_getpwent:
3485             FUN0(OP_GPWENT);
3486
3487         case KEY_getpwnam:
3488             UNI(OP_GPWNAM);
3489
3490         case KEY_getpwuid:
3491             UNI(OP_GPWUID);
3492
3493         case KEY_getpeername:
3494             UNI(OP_GETPEERNAME);
3495
3496         case KEY_gethostbyname:
3497             UNI(OP_GHBYNAME);
3498
3499         case KEY_gethostbyaddr:
3500             LOP(OP_GHBYADDR,XTERM);
3501
3502         case KEY_gethostent:
3503             FUN0(OP_GHOSTENT);
3504
3505         case KEY_getnetbyname:
3506             UNI(OP_GNBYNAME);
3507
3508         case KEY_getnetbyaddr:
3509             LOP(OP_GNBYADDR,XTERM);
3510
3511         case KEY_getnetent:
3512             FUN0(OP_GNETENT);
3513
3514         case KEY_getservbyname:
3515             LOP(OP_GSBYNAME,XTERM);
3516
3517         case KEY_getservbyport:
3518             LOP(OP_GSBYPORT,XTERM);
3519
3520         case KEY_getservent:
3521             FUN0(OP_GSERVENT);
3522
3523         case KEY_getsockname:
3524             UNI(OP_GETSOCKNAME);
3525
3526         case KEY_getsockopt:
3527             LOP(OP_GSOCKOPT,XTERM);
3528
3529         case KEY_getgrent:
3530             FUN0(OP_GGRENT);
3531
3532         case KEY_getgrnam:
3533             UNI(OP_GGRNAM);
3534
3535         case KEY_getgrgid:
3536             UNI(OP_GGRGID);
3537
3538         case KEY_getlogin:
3539             FUN0(OP_GETLOGIN);
3540
3541         case KEY_glob:
3542             set_csh();
3543             LOP(OP_GLOB,XTERM);
3544
3545         case KEY_hex:
3546             UNI(OP_HEX);
3547
3548         case KEY_if:
3549             yylval.ival = PL_curcop->cop_line;
3550             OPERATOR(IF);
3551
3552         case KEY_index:
3553             LOP(OP_INDEX,XTERM);
3554
3555         case KEY_int:
3556             UNI(OP_INT);
3557
3558         case KEY_ioctl:
3559             LOP(OP_IOCTL,XTERM);
3560
3561         case KEY_join:
3562             LOP(OP_JOIN,XTERM);
3563
3564         case KEY_keys:
3565             UNI(OP_KEYS);
3566
3567         case KEY_kill:
3568             LOP(OP_KILL,XTERM);
3569
3570         case KEY_last:
3571             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3572             LOOPX(OP_LAST);
3573
3574         case KEY_lc:
3575             UNI(OP_LC);
3576
3577         case KEY_lcfirst:
3578             UNI(OP_LCFIRST);
3579
3580         case KEY_local:
3581             OPERATOR(LOCAL);
3582
3583         case KEY_length:
3584             UNI(OP_LENGTH);
3585
3586         case KEY_lt:
3587             Rop(OP_SLT);
3588
3589         case KEY_le:
3590             Rop(OP_SLE);
3591
3592         case KEY_localtime:
3593             UNI(OP_LOCALTIME);
3594
3595         case KEY_log:
3596             UNI(OP_LOG);
3597
3598         case KEY_link:
3599             LOP(OP_LINK,XTERM);
3600
3601         case KEY_listen:
3602             LOP(OP_LISTEN,XTERM);
3603
3604         case KEY_lock:
3605             UNI(OP_LOCK);
3606
3607         case KEY_lstat:
3608             UNI(OP_LSTAT);
3609
3610         case KEY_m:
3611             s = scan_pat(s,OP_MATCH);
3612             TERM(sublex_start());
3613
3614         case KEY_map:
3615             LOP(OP_MAPSTART,XREF);
3616
3617         case KEY_mkdir:
3618             LOP(OP_MKDIR,XTERM);
3619
3620         case KEY_msgctl:
3621             LOP(OP_MSGCTL,XTERM);
3622
3623         case KEY_msgget:
3624             LOP(OP_MSGGET,XTERM);
3625
3626         case KEY_msgrcv:
3627             LOP(OP_MSGRCV,XTERM);
3628
3629         case KEY_msgsnd:
3630             LOP(OP_MSGSND,XTERM);
3631
3632         case KEY_my:
3633             PL_in_my = TRUE;
3634             s = skipspace(s);
3635             if (isIDFIRST(*s)) {
3636                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3637                 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3638                 if (!PL_in_my_stash) {
3639                     char tmpbuf[1024];
3640                     PL_bufptr = s;
3641                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3642                     yyerror(tmpbuf);
3643                 }
3644             }
3645             OPERATOR(MY);
3646
3647         case KEY_next:
3648             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3649             LOOPX(OP_NEXT);
3650
3651         case KEY_ne:
3652             Eop(OP_SNE);
3653
3654         case KEY_no:
3655             if (PL_expect != XSTATE)
3656                 yyerror("\"no\" not allowed in expression");
3657             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3658             s = force_version(s);
3659             yylval.ival = 0;
3660             OPERATOR(USE);
3661
3662         case KEY_not:
3663             OPERATOR(NOTOP);
3664
3665         case KEY_open:
3666             s = skipspace(s);
3667             if (isIDFIRST(*s)) {
3668                 char *t;
3669                 for (d = s; isALNUM(*d); d++) ;
3670                 t = skipspace(d);
3671                 if (strchr("|&*+-=!?:.", *t))
3672                     warn("Precedence problem: open %.*s should be open(%.*s)",
3673                         d-s,s, d-s,s);
3674             }
3675             LOP(OP_OPEN,XTERM);
3676
3677         case KEY_or:
3678             yylval.ival = OP_OR;
3679             OPERATOR(OROP);
3680
3681         case KEY_ord:
3682             UNI(OP_ORD);
3683
3684         case KEY_oct:
3685             UNI(OP_OCT);
3686
3687         case KEY_opendir:
3688             LOP(OP_OPEN_DIR,XTERM);
3689
3690         case KEY_print:
3691             checkcomma(s,PL_tokenbuf,"filehandle");
3692             LOP(OP_PRINT,XREF);
3693
3694         case KEY_printf:
3695             checkcomma(s,PL_tokenbuf,"filehandle");
3696             LOP(OP_PRTF,XREF);
3697
3698         case KEY_prototype:
3699             UNI(OP_PROTOTYPE);
3700
3701         case KEY_push:
3702             LOP(OP_PUSH,XTERM);
3703
3704         case KEY_pop:
3705             UNI(OP_POP);
3706
3707         case KEY_pos:
3708             UNI(OP_POS);
3709
3710         case KEY_pack:
3711             LOP(OP_PACK,XTERM);
3712
3713         case KEY_package:
3714             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3715             OPERATOR(PACKAGE);
3716
3717         case KEY_pipe:
3718             LOP(OP_PIPE_OP,XTERM);
3719
3720         case KEY_q:
3721             s = scan_str(s);
3722             if (!s)
3723                 missingterm((char*)0);
3724             yylval.ival = OP_CONST;
3725             TERM(sublex_start());
3726
3727         case KEY_quotemeta:
3728             UNI(OP_QUOTEMETA);
3729
3730         case KEY_qw:
3731             s = scan_str(s);
3732             if (!s)
3733                 missingterm((char*)0);
3734             if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3735                 d = SvPV_force(PL_lex_stuff, len);
3736                 for (; len; --len, ++d) {
3737                     if (*d == ',') {
3738                         warner(WARN_SYNTAX,
3739                             "Possible attempt to separate words with commas");
3740                         break;
3741                     }
3742                     if (*d == '#') {
3743                         warner(WARN_SYNTAX,
3744                             "Possible attempt to put comments in qw() list");
3745                         break;
3746                     }
3747                 }
3748             }
3749             force_next(')');
3750             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3751             PL_lex_stuff = Nullsv;
3752             force_next(THING);
3753             force_next(',');
3754             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3755             force_next(THING);
3756             force_next('(');
3757             yylval.ival = OP_SPLIT;
3758             CLINE;
3759             PL_expect = XTERM;
3760             PL_bufptr = s;
3761             PL_last_lop = PL_oldbufptr;
3762             PL_last_lop_op = OP_SPLIT;
3763             return FUNC;
3764
3765         case KEY_qq:
3766             s = scan_str(s);
3767             if (!s)
3768                 missingterm((char*)0);
3769             yylval.ival = OP_STRINGIFY;
3770             if (SvIVX(PL_lex_stuff) == '\'')
3771                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
3772             TERM(sublex_start());
3773
3774         case KEY_qr:
3775             s = scan_pat(s,OP_QR);
3776             TERM(sublex_start());
3777
3778         case KEY_qx:
3779             s = scan_str(s);
3780             if (!s)
3781                 missingterm((char*)0);
3782             yylval.ival = OP_BACKTICK;
3783             set_csh();
3784             TERM(sublex_start());
3785
3786         case KEY_return:
3787             OLDLOP(OP_RETURN);
3788
3789         case KEY_require:
3790             *PL_tokenbuf = '\0';
3791             s = force_word(s,WORD,TRUE,TRUE,FALSE);
3792             if (isIDFIRST(*PL_tokenbuf))
3793                 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3794             else if (*s == '<')
3795                 yyerror("<> should be quotes");
3796             UNI(OP_REQUIRE);
3797
3798         case KEY_reset:
3799             UNI(OP_RESET);
3800
3801         case KEY_redo:
3802             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3803             LOOPX(OP_REDO);
3804
3805         case KEY_rename:
3806             LOP(OP_RENAME,XTERM);
3807
3808         case KEY_rand:
3809             UNI(OP_RAND);
3810
3811         case KEY_rmdir:
3812             UNI(OP_RMDIR);
3813
3814         case KEY_rindex:
3815             LOP(OP_RINDEX,XTERM);
3816
3817         case KEY_read:
3818             LOP(OP_READ,XTERM);
3819
3820         case KEY_readdir:
3821             UNI(OP_READDIR);
3822
3823         case KEY_readline:
3824             set_csh();
3825             UNI(OP_READLINE);
3826
3827         case KEY_readpipe:
3828             set_csh();
3829             UNI(OP_BACKTICK);
3830
3831         case KEY_rewinddir:
3832             UNI(OP_REWINDDIR);
3833
3834         case KEY_recv:
3835             LOP(OP_RECV,XTERM);
3836
3837         case KEY_reverse:
3838             LOP(OP_REVERSE,XTERM);
3839
3840         case KEY_readlink:
3841             UNI(OP_READLINK);
3842
3843         case KEY_ref:
3844             UNI(OP_REF);
3845
3846         case KEY_s:
3847             s = scan_subst(s);
3848             if (yylval.opval)
3849                 TERM(sublex_start());
3850             else
3851                 TOKEN(1);       /* force error */
3852
3853         case KEY_chomp:
3854             UNI(OP_CHOMP);
3855
3856         case KEY_scalar:
3857             UNI(OP_SCALAR);
3858
3859         case KEY_select:
3860             LOP(OP_SELECT,XTERM);
3861
3862         case KEY_seek:
3863             LOP(OP_SEEK,XTERM);
3864
3865         case KEY_semctl:
3866             LOP(OP_SEMCTL,XTERM);
3867
3868         case KEY_semget:
3869             LOP(OP_SEMGET,XTERM);
3870
3871         case KEY_semop:
3872             LOP(OP_SEMOP,XTERM);
3873
3874         case KEY_send:
3875             LOP(OP_SEND,XTERM);
3876
3877         case KEY_setpgrp:
3878             LOP(OP_SETPGRP,XTERM);
3879
3880         case KEY_setpriority:
3881             LOP(OP_SETPRIORITY,XTERM);
3882
3883         case KEY_sethostent:
3884             UNI(OP_SHOSTENT);
3885
3886         case KEY_setnetent:
3887             UNI(OP_SNETENT);
3888
3889         case KEY_setservent:
3890             UNI(OP_SSERVENT);
3891
3892         case KEY_setprotoent:
3893             UNI(OP_SPROTOENT);
3894
3895         case KEY_setpwent:
3896             FUN0(OP_SPWENT);
3897
3898         case KEY_setgrent:
3899             FUN0(OP_SGRENT);
3900
3901         case KEY_seekdir:
3902             LOP(OP_SEEKDIR,XTERM);
3903
3904         case KEY_setsockopt:
3905             LOP(OP_SSOCKOPT,XTERM);
3906
3907         case KEY_shift:
3908             UNI(OP_SHIFT);
3909
3910         case KEY_shmctl:
3911             LOP(OP_SHMCTL,XTERM);
3912
3913         case KEY_shmget:
3914             LOP(OP_SHMGET,XTERM);
3915
3916         case KEY_shmread:
3917             LOP(OP_SHMREAD,XTERM);
3918
3919         case KEY_shmwrite:
3920             LOP(OP_SHMWRITE,XTERM);
3921
3922         case KEY_shutdown:
3923             LOP(OP_SHUTDOWN,XTERM);
3924
3925         case KEY_sin:
3926             UNI(OP_SIN);
3927
3928         case KEY_sleep:
3929             UNI(OP_SLEEP);
3930
3931         case KEY_socket:
3932             LOP(OP_SOCKET,XTERM);
3933
3934         case KEY_socketpair:
3935             LOP(OP_SOCKPAIR,XTERM);
3936
3937         case KEY_sort:
3938             checkcomma(s,PL_tokenbuf,"subroutine name");
3939             s = skipspace(s);
3940             if (*s == ';' || *s == ')')         /* probably a close */
3941                 croak("sort is now a reserved word");
3942             PL_expect = XTERM;
3943             s = force_word(s,WORD,TRUE,TRUE,FALSE);
3944             LOP(OP_SORT,XREF);
3945
3946         case KEY_split:
3947             LOP(OP_SPLIT,XTERM);
3948
3949         case KEY_sprintf:
3950             LOP(OP_SPRINTF,XTERM);
3951
3952         case KEY_splice:
3953             LOP(OP_SPLICE,XTERM);
3954
3955         case KEY_sqrt:
3956             UNI(OP_SQRT);
3957
3958         case KEY_srand:
3959             UNI(OP_SRAND);
3960
3961         case KEY_stat:
3962             UNI(OP_STAT);
3963
3964         case KEY_study:
3965             PL_sawstudy++;
3966             UNI(OP_STUDY);
3967
3968         case KEY_substr:
3969             LOP(OP_SUBSTR,XTERM);
3970
3971         case KEY_format:
3972         case KEY_sub:
3973           really_sub:
3974             s = skipspace(s);
3975
3976             if (isIDFIRST(*s) || *s == '\'' || *s == ':') {
3977                 char tmpbuf[sizeof PL_tokenbuf];
3978                 PL_expect = XBLOCK;
3979                 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
3980                 if (strchr(tmpbuf, ':'))
3981                     sv_setpv(PL_subname, tmpbuf);
3982                 else {
3983                     sv_setsv(PL_subname,PL_curstname);
3984                     sv_catpvn(PL_subname,"::",2);
3985                     sv_catpvn(PL_subname,tmpbuf,len);
3986                 }
3987                 s = force_word(s,WORD,FALSE,TRUE,TRUE);
3988                 s = skipspace(s);
3989             }
3990             else {
3991                 PL_expect = XTERMBLOCK;
3992                 sv_setpv(PL_subname,"?");
3993             }
3994
3995             if (tmp == KEY_format) {
3996                 s = skipspace(s);
3997                 if (*s == '=')
3998                     PL_lex_formbrack = PL_lex_brackets + 1;
3999                 OPERATOR(FORMAT);
4000             }
4001
4002             /* Look for a prototype */
4003             if (*s == '(') {
4004                 char *p;
4005
4006                 s = scan_str(s);
4007                 if (!s) {
4008                     if (PL_lex_stuff)
4009                         SvREFCNT_dec(PL_lex_stuff);
4010                     PL_lex_stuff = Nullsv;
4011                     croak("Prototype not terminated");
4012                 }
4013                 /* strip spaces */
4014                 d = SvPVX(PL_lex_stuff);
4015                 tmp = 0;
4016                 for (p = d; *p; ++p) {
4017                     if (!isSPACE(*p))
4018                         d[tmp++] = *p;
4019                 }
4020                 d[tmp] = '\0';
4021                 SvCUR(PL_lex_stuff) = tmp;
4022
4023                 PL_nexttoke++;
4024                 PL_nextval[1] = PL_nextval[0];
4025                 PL_nexttype[1] = PL_nexttype[0];
4026                 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4027                 PL_nexttype[0] = THING;
4028                 if (PL_nexttoke == 1) {
4029                     PL_lex_defer = PL_lex_state;
4030                     PL_lex_expect = PL_expect;
4031                     PL_lex_state = LEX_KNOWNEXT;
4032                 }
4033                 PL_lex_stuff = Nullsv;
4034             }
4035
4036             if (*SvPV(PL_subname,PL_na) == '?') {
4037                 sv_setpv(PL_subname,"__ANON__");
4038                 TOKEN(ANONSUB);
4039             }
4040             PREBLOCK(SUB);
4041
4042         case KEY_system:
4043             set_csh();
4044             LOP(OP_SYSTEM,XREF);
4045
4046         case KEY_symlink:
4047             LOP(OP_SYMLINK,XTERM);
4048
4049         case KEY_syscall:
4050             LOP(OP_SYSCALL,XTERM);
4051
4052         case KEY_sysopen:
4053             LOP(OP_SYSOPEN,XTERM);
4054
4055         case KEY_sysseek:
4056             LOP(OP_SYSSEEK,XTERM);
4057
4058         case KEY_sysread:
4059             LOP(OP_SYSREAD,XTERM);
4060
4061         case KEY_syswrite:
4062             LOP(OP_SYSWRITE,XTERM);
4063
4064         case KEY_tr:
4065             s = scan_trans(s);
4066             TERM(sublex_start());
4067
4068         case KEY_tell:
4069             UNI(OP_TELL);
4070
4071         case KEY_telldir:
4072             UNI(OP_TELLDIR);
4073
4074         case KEY_tie:
4075             LOP(OP_TIE,XTERM);
4076
4077         case KEY_tied:
4078             UNI(OP_TIED);
4079
4080         case KEY_time:
4081             FUN0(OP_TIME);
4082
4083         case KEY_times:
4084             FUN0(OP_TMS);
4085
4086         case KEY_truncate:
4087             LOP(OP_TRUNCATE,XTERM);
4088
4089         case KEY_uc:
4090             UNI(OP_UC);
4091
4092         case KEY_ucfirst:
4093             UNI(OP_UCFIRST);
4094
4095         case KEY_untie:
4096             UNI(OP_UNTIE);
4097
4098         case KEY_until:
4099             yylval.ival = PL_curcop->cop_line;
4100             OPERATOR(UNTIL);
4101
4102         case KEY_unless:
4103             yylval.ival = PL_curcop->cop_line;
4104             OPERATOR(UNLESS);
4105
4106         case KEY_unlink:
4107             LOP(OP_UNLINK,XTERM);
4108
4109         case KEY_undef:
4110             UNI(OP_UNDEF);
4111
4112         case KEY_unpack:
4113             LOP(OP_UNPACK,XTERM);
4114
4115         case KEY_utime:
4116             LOP(OP_UTIME,XTERM);
4117
4118         case KEY_umask:
4119             if (ckWARN(WARN_OCTAL)) {
4120                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4121                 if (*d != '0' && isDIGIT(*d))
4122                     yywarn("umask: argument is missing initial 0");
4123             }
4124             UNI(OP_UMASK);
4125
4126         case KEY_unshift:
4127             LOP(OP_UNSHIFT,XTERM);
4128
4129         case KEY_use:
4130             if (PL_expect != XSTATE)
4131                 yyerror("\"use\" not allowed in expression");
4132             s = skipspace(s);
4133             if(isDIGIT(*s)) {
4134                 s = force_version(s);
4135                 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4136                     PL_nextval[PL_nexttoke].opval = Nullop;
4137                     force_next(WORD);
4138                 }
4139             }
4140             else {
4141                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4142                 s = force_version(s);
4143             }
4144             yylval.ival = 1;
4145             OPERATOR(USE);
4146
4147         case KEY_values:
4148             UNI(OP_VALUES);
4149
4150         case KEY_vec:
4151             PL_sawvec = TRUE;
4152             LOP(OP_VEC,XTERM);
4153
4154         case KEY_while:
4155             yylval.ival = PL_curcop->cop_line;
4156             OPERATOR(WHILE);
4157
4158         case KEY_warn:
4159             PL_hints |= HINT_BLOCK_SCOPE;
4160             LOP(OP_WARN,XTERM);
4161
4162         case KEY_wait:
4163             FUN0(OP_WAIT);
4164
4165         case KEY_waitpid:
4166             LOP(OP_WAITPID,XTERM);
4167
4168         case KEY_wantarray:
4169             FUN0(OP_WANTARRAY);
4170
4171         case KEY_write:
4172 #ifdef EBCDIC
4173         {
4174             static char ctl_l[2];
4175
4176             if (ctl_l[0] == '\0')
4177                 ctl_l[0] = toCTRL('L');
4178             gv_fetchpv(ctl_l,TRUE, SVt_PV);
4179         }
4180 #else
4181             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
4182 #endif
4183             UNI(OP_ENTERWRITE);
4184
4185         case KEY_x:
4186             if (PL_expect == XOPERATOR)
4187                 Mop(OP_REPEAT);
4188             check_uni();
4189             goto just_a_word;
4190
4191         case KEY_xor:
4192             yylval.ival = OP_XOR;
4193             OPERATOR(OROP);
4194
4195         case KEY_y:
4196             s = scan_trans(s);
4197             TERM(sublex_start());
4198         }
4199     }}
4200 }
4201
4202 I32
4203 keyword(register char *d, I32 len)
4204 {
4205     switch (*d) {
4206     case '_':
4207         if (d[1] == '_') {
4208             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
4209             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
4210             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
4211             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
4212             if (strEQ(d,"__END__"))             return KEY___END__;
4213         }
4214         break;
4215     case 'A':
4216         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
4217         break;
4218     case 'a':
4219         switch (len) {
4220         case 3:
4221             if (strEQ(d,"and"))                 return -KEY_and;
4222             if (strEQ(d,"abs"))                 return -KEY_abs;
4223             break;
4224         case 5:
4225             if (strEQ(d,"alarm"))               return -KEY_alarm;
4226             if (strEQ(d,"atan2"))               return -KEY_atan2;
4227             break;
4228         case 6:
4229             if (strEQ(d,"accept"))              return -KEY_accept;
4230             break;
4231         }
4232         break;
4233     case 'B':
4234         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
4235         break;
4236     case 'b':
4237         if (strEQ(d,"bless"))                   return -KEY_bless;
4238         if (strEQ(d,"bind"))                    return -KEY_bind;
4239         if (strEQ(d,"binmode"))                 return -KEY_binmode;
4240         break;
4241     case 'C':
4242         if (strEQ(d,"CORE"))                    return -KEY_CORE;
4243         break;
4244     case 'c':
4245         switch (len) {
4246         case 3:
4247             if (strEQ(d,"cmp"))                 return -KEY_cmp;
4248             if (strEQ(d,"chr"))                 return -KEY_chr;
4249             if (strEQ(d,"cos"))                 return -KEY_cos;
4250             break;
4251         case 4:
4252             if (strEQ(d,"chop"))                return KEY_chop;
4253             break;
4254         case 5:
4255             if (strEQ(d,"close"))               return -KEY_close;
4256             if (strEQ(d,"chdir"))               return -KEY_chdir;
4257             if (strEQ(d,"chomp"))               return KEY_chomp;
4258             if (strEQ(d,"chmod"))               return -KEY_chmod;
4259             if (strEQ(d,"chown"))               return -KEY_chown;
4260             if (strEQ(d,"crypt"))               return -KEY_crypt;
4261             break;
4262         case 6:
4263             if (strEQ(d,"chroot"))              return -KEY_chroot;
4264             if (strEQ(d,"caller"))              return -KEY_caller;
4265             break;
4266         case 7:
4267             if (strEQ(d,"connect"))             return -KEY_connect;
4268             break;
4269         case 8:
4270             if (strEQ(d,"closedir"))            return -KEY_closedir;
4271             if (strEQ(d,"continue"))            return -KEY_continue;
4272             break;
4273         }
4274         break;
4275     case 'D':
4276         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
4277         break;
4278     case 'd':
4279         switch (len) {
4280         case 2:
4281             if (strEQ(d,"do"))                  return KEY_do;
4282             break;
4283         case 3:
4284             if (strEQ(d,"die"))                 return -KEY_die;
4285             break;
4286         case 4:
4287             if (strEQ(d,"dump"))                return -KEY_dump;
4288             break;
4289         case 6:
4290             if (strEQ(d,"delete"))              return KEY_delete;
4291             break;
4292         case 7:
4293             if (strEQ(d,"defined"))             return KEY_defined;
4294             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
4295             break;
4296         case 8:
4297             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
4298             break;
4299         }
4300         break;
4301     case 'E':
4302         if (strEQ(d,"EQ")) { deprecate(d);      return -KEY_eq;}
4303         if (strEQ(d,"END"))                     return KEY_END;
4304         break;
4305     case 'e':
4306         switch (len) {
4307         case 2:
4308             if (strEQ(d,"eq"))                  return -KEY_eq;
4309             break;
4310         case 3:
4311             if (strEQ(d,"eof"))                 return -KEY_eof;
4312             if (strEQ(d,"exp"))                 return -KEY_exp;
4313             break;
4314         case 4:
4315             if (strEQ(d,"else"))                return KEY_else;
4316             if (strEQ(d,"exit"))                return -KEY_exit;
4317             if (strEQ(d,"eval"))                return KEY_eval;
4318             if (strEQ(d,"exec"))                return -KEY_exec;
4319             if (strEQ(d,"each"))                return KEY_each;
4320             break;
4321         case 5:
4322             if (strEQ(d,"elsif"))               return KEY_elsif;
4323             break;
4324         case 6:
4325             if (strEQ(d,"exists"))              return KEY_exists;
4326             if (strEQ(d,"elseif")) warn("elseif should be elsif");
4327             break;
4328         case 8:
4329             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
4330             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
4331             break;
4332         case 9:
4333             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
4334             break;
4335         case 10:
4336             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
4337             if (strEQ(d,"endservent"))          return -KEY_endservent;
4338             break;
4339         case 11:
4340             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
4341             break;
4342         }
4343         break;
4344     case 'f':
4345         switch (len) {
4346         case 3:
4347             if (strEQ(d,"for"))                 return KEY_for;
4348             break;
4349         case 4:
4350             if (strEQ(d,"fork"))                return -KEY_fork;
4351             break;
4352         case 5:
4353             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
4354             if (strEQ(d,"flock"))               return -KEY_flock;
4355             break;
4356         case 6:
4357             if (strEQ(d,"format"))              return KEY_format;
4358             if (strEQ(d,"fileno"))              return -KEY_fileno;
4359             break;
4360         case 7:
4361             if (strEQ(d,"foreach"))             return KEY_foreach;
4362             break;
4363         case 8:
4364             if (strEQ(d,"formline"))            return -KEY_formline;
4365             break;
4366         }
4367         break;
4368     case 'G':
4369         if (len == 2) {
4370             if (strEQ(d,"GT")) { deprecate(d);  return -KEY_gt;}
4371             if (strEQ(d,"GE")) { deprecate(d);  return -KEY_ge;}
4372         }
4373         break;
4374     case 'g':
4375         if (strnEQ(d,"get",3)) {
4376             d += 3;
4377             if (*d == 'p') {
4378                 switch (len) {
4379                 case 7:
4380                     if (strEQ(d,"ppid"))        return -KEY_getppid;
4381                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
4382                     break;
4383                 case 8:
4384                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
4385                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
4386                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
4387                     break;
4388                 case 11:
4389                     if (strEQ(d,"peername"))    return -KEY_getpeername;
4390                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
4391                     if (strEQ(d,"priority"))    return -KEY_getpriority;
4392                     break;
4393                 case 14:
4394                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4395                     break;
4396                 case 16:
4397                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4398                     break;
4399                 }
4400             }
4401             else if (*d == 'h') {
4402                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
4403                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
4404                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
4405             }
4406             else if (*d == 'n') {
4407                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
4408                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
4409                 if (strEQ(d,"netent"))          return -KEY_getnetent;
4410             }
4411             else if (*d == 's') {
4412                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
4413                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
4414                 if (strEQ(d,"servent"))         return -KEY_getservent;
4415                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
4416                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
4417             }
4418             else if (*d == 'g') {
4419                 if (strEQ(d,"grent"))           return -KEY_getgrent;
4420                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
4421                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
4422             }
4423             else if (*d == 'l') {
4424                 if (strEQ(d,"login"))           return -KEY_getlogin;
4425             }
4426             else if (strEQ(d,"c"))              return -KEY_getc;
4427             break;
4428         }
4429         switch (len) {
4430         case 2:
4431             if (strEQ(d,"gt"))                  return -KEY_gt;
4432             if (strEQ(d,"ge"))                  return -KEY_ge;
4433             break;
4434         case 4:
4435             if (strEQ(d,"grep"))                return KEY_grep;
4436             if (strEQ(d,"goto"))                return KEY_goto;
4437             if (strEQ(d,"glob"))                return KEY_glob;
4438             break;
4439         case 6:
4440             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
4441             break;
4442         }
4443         break;
4444     case 'h':
4445         if (strEQ(d,"hex"))                     return -KEY_hex;
4446         break;
4447     case 'I':
4448         if (strEQ(d,"INIT"))                    return KEY_INIT;
4449         break;
4450     case 'i':
4451         switch (len) {
4452         case 2:
4453             if (strEQ(d,"if"))                  return KEY_if;
4454             break;
4455         case 3:
4456             if (strEQ(d,"int"))                 return -KEY_int;
4457             break;
4458         case 5:
4459             if (strEQ(d,"index"))               return -KEY_index;
4460             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
4461             break;
4462         }
4463         break;
4464     case 'j':
4465         if (strEQ(d,"join"))                    return -KEY_join;
4466         break;
4467     case 'k':
4468         if (len == 4) {
4469             if (strEQ(d,"keys"))                return KEY_keys;
4470             if (strEQ(d,"kill"))                return -KEY_kill;
4471         }
4472         break;
4473     case 'L':
4474         if (len == 2) {
4475             if (strEQ(d,"LT")) { deprecate(d);  return -KEY_lt;}
4476             if (strEQ(d,"LE")) { deprecate(d);  return -KEY_le;}
4477         }
4478         break;
4479     case 'l':
4480         switch (len) {
4481         case 2:
4482             if (strEQ(d,"lt"))                  return -KEY_lt;
4483             if (strEQ(d,"le"))                  return -KEY_le;
4484             if (strEQ(d,"lc"))                  return -KEY_lc;
4485             break;
4486         case 3:
4487             if (strEQ(d,"log"))                 return -KEY_log;
4488             break;
4489         case 4:
4490             if (strEQ(d,"last"))                return KEY_last;
4491             if (strEQ(d,"link"))                return -KEY_link;
4492             if (strEQ(d,"lock"))                return -KEY_lock;
4493             break;
4494         case 5:
4495             if (strEQ(d,"local"))               return KEY_local;
4496             if (strEQ(d,"lstat"))               return -KEY_lstat;
4497             break;
4498         case 6:
4499             if (strEQ(d,"length"))              return -KEY_length;
4500             if (strEQ(d,"listen"))              return -KEY_listen;
4501             break;
4502         case 7:
4503             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
4504             break;
4505         case 9:
4506             if (strEQ(d,"localtime"))           return -KEY_localtime;
4507             break;
4508         }
4509         break;
4510     case 'm':
4511         switch (len) {
4512         case 1:                                 return KEY_m;
4513         case 2:
4514             if (strEQ(d,"my"))                  return KEY_my;
4515             break;
4516         case 3:
4517             if (strEQ(d,"map"))                 return KEY_map;
4518             break;
4519         case 5:
4520             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
4521             break;
4522         case 6:
4523             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
4524             if (strEQ(d,"msgget"))              return -KEY_msgget;
4525             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
4526             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
4527             break;
4528         }
4529         break;
4530     case 'N':
4531         if (strEQ(d,"NE")) { deprecate(d);      return -KEY_ne;}
4532         break;
4533     case 'n':
4534         if (strEQ(d,"next"))                    return KEY_next;
4535         if (strEQ(d,"ne"))                      return -KEY_ne;
4536         if (strEQ(d,"not"))                     return -KEY_not;
4537         if (strEQ(d,"no"))                      return KEY_no;
4538         break;
4539     case 'o':
4540         switch (len) {
4541         case 2:
4542             if (strEQ(d,"or"))                  return -KEY_or;
4543             break;
4544         case 3:
4545             if (strEQ(d,"ord"))                 return -KEY_ord;
4546             if (strEQ(d,"oct"))                 return -KEY_oct;
4547             if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4548                                                 return 0;}
4549             break;
4550         case 4:
4551             if (strEQ(d,"open"))                return -KEY_open;
4552             break;
4553         case 7:
4554             if (strEQ(d,"opendir"))             return -KEY_opendir;
4555             break;
4556         }
4557         break;
4558     case 'p':
4559         switch (len) {
4560         case 3:
4561             if (strEQ(d,"pop"))                 return KEY_pop;
4562             if (strEQ(d,"pos"))                 return KEY_pos;
4563             break;
4564         case 4:
4565             if (strEQ(d,"push"))                return KEY_push;
4566             if (strEQ(d,"pack"))                return -KEY_pack;
4567             if (strEQ(d,"pipe"))                return -KEY_pipe;
4568             break;
4569         case 5:
4570             if (strEQ(d,"print"))               return KEY_print;
4571             break;
4572         case 6:
4573             if (strEQ(d,"printf"))              return KEY_printf;
4574             break;
4575         case 7:
4576             if (strEQ(d,"package"))             return KEY_package;
4577             break;
4578         case 9:
4579             if (strEQ(d,"prototype"))           return KEY_prototype;
4580         }
4581         break;
4582     case 'q':
4583         if (len <= 2) {
4584             if (strEQ(d,"q"))                   return KEY_q;
4585             if (strEQ(d,"qr"))                  return KEY_qr;
4586             if (strEQ(d,"qq"))                  return KEY_qq;
4587             if (strEQ(d,"qw"))                  return KEY_qw;
4588             if (strEQ(d,"qx"))                  return KEY_qx;
4589         }
4590         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
4591         break;
4592     case 'r':
4593         switch (len) {
4594         case 3:
4595             if (strEQ(d,"ref"))                 return -KEY_ref;
4596             break;
4597         case 4:
4598             if (strEQ(d,"read"))                return -KEY_read;
4599             if (strEQ(d,"rand"))                return -KEY_rand;
4600             if (strEQ(d,"recv"))                return -KEY_recv;
4601             if (strEQ(d,"redo"))                return KEY_redo;
4602             break;
4603         case 5:
4604             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
4605             if (strEQ(d,"reset"))               return -KEY_reset;
4606             break;
4607         case 6:
4608             if (strEQ(d,"return"))              return KEY_return;
4609             if (strEQ(d,"rename"))              return -KEY_rename;
4610             if (strEQ(d,"rindex"))              return -KEY_rindex;
4611             break;
4612         case 7:
4613             if (strEQ(d,"require"))             return -KEY_require;
4614             if (strEQ(d,"reverse"))             return -KEY_reverse;
4615             if (strEQ(d,"readdir"))             return -KEY_readdir;
4616             break;
4617         case 8:
4618             if (strEQ(d,"readlink"))            return -KEY_readlink;
4619             if (strEQ(d,"readline"))            return -KEY_readline;
4620             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
4621             break;
4622         case 9:
4623             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
4624             break;
4625         }
4626         break;
4627     case 's':
4628         switch (d[1]) {
4629         case 0:                                 return KEY_s;
4630         case 'c':
4631             if (strEQ(d,"scalar"))              return KEY_scalar;
4632             break;
4633         case 'e':
4634             switch (len) {
4635             case 4:
4636                 if (strEQ(d,"seek"))            return -KEY_seek;
4637                 if (strEQ(d,"send"))            return -KEY_send;
4638                 break;
4639             case 5:
4640                 if (strEQ(d,"semop"))           return -KEY_semop;
4641                 break;
4642             case 6:
4643                 if (strEQ(d,"select"))          return -KEY_select;
4644                 if (strEQ(d,"semctl"))          return -KEY_semctl;
4645                 if (strEQ(d,"semget"))          return -KEY_semget;
4646                 break;
4647             case 7:
4648                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
4649                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
4650                 break;
4651             case 8:
4652                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
4653                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
4654                 break;
4655             case 9:
4656                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
4657                 break;
4658             case 10:
4659                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
4660                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
4661                 if (strEQ(d,"setservent"))      return -KEY_setservent;
4662                 break;
4663             case 11:
4664                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
4665                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
4666                 break;
4667             }
4668             break;
4669         case 'h':
4670             switch (len) {
4671             case 5:
4672                 if (strEQ(d,"shift"))           return KEY_shift;
4673                 break;
4674             case 6:
4675                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
4676                 if (strEQ(d,"shmget"))          return -KEY_shmget;
4677                 break;
4678             case 7:
4679                 if (strEQ(d,"shmread"))         return -KEY_shmread;
4680                 break;
4681             case 8:
4682                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
4683                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
4684                 break;
4685             }
4686             break;
4687         case 'i':
4688             if (strEQ(d,"sin"))                 return -KEY_sin;
4689             break;
4690         case 'l':
4691             if (strEQ(d,"sleep"))               return -KEY_sleep;
4692             break;
4693         case 'o':
4694             if (strEQ(d,"sort"))                return KEY_sort;
4695             if (strEQ(d,"socket"))              return -KEY_socket;
4696             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
4697             break;
4698         case 'p':
4699             if (strEQ(d,"split"))               return KEY_split;
4700             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
4701             if (strEQ(d,"splice"))              return KEY_splice;
4702             break;
4703         case 'q':
4704             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
4705             break;
4706         case 'r':
4707             if (strEQ(d,"srand"))               return -KEY_srand;
4708             break;
4709         case 't':
4710             if (strEQ(d,"stat"))                return -KEY_stat;
4711             if (strEQ(d,"study"))               return KEY_study;
4712             break;
4713         case 'u':
4714             if (strEQ(d,"substr"))              return -KEY_substr;
4715             if (strEQ(d,"sub"))                 return KEY_sub;
4716             break;
4717         case 'y':
4718             switch (len) {
4719             case 6:
4720                 if (strEQ(d,"system"))          return -KEY_system;
4721                 break;
4722             case 7:
4723                 if (strEQ(d,"symlink"))         return -KEY_symlink;
4724                 if (strEQ(d,"syscall"))         return -KEY_syscall;
4725                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
4726                 if (strEQ(d,"sysread"))         return -KEY_sysread;
4727                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
4728                 break;
4729             case 8:
4730                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
4731                 break;
4732             }
4733             break;
4734         }
4735         break;
4736     case 't':
4737         switch (len) {
4738         case 2:
4739             if (strEQ(d,"tr"))                  return KEY_tr;
4740             break;
4741         case 3:
4742             if (strEQ(d,"tie"))                 return KEY_tie;
4743             break;
4744         case 4:
4745             if (strEQ(d,"tell"))                return -KEY_tell;
4746             if (strEQ(d,"tied"))                return KEY_tied;
4747             if (strEQ(d,"time"))                return -KEY_time;
4748             break;
4749         case 5:
4750             if (strEQ(d,"times"))               return -KEY_times;
4751             break;
4752         case 7:
4753             if (strEQ(d,"telldir"))             return -KEY_telldir;
4754             break;
4755         case 8:
4756             if (strEQ(d,"truncate"))            return -KEY_truncate;
4757             break;
4758         }
4759         break;
4760     case 'u':
4761         switch (len) {
4762         case 2:
4763             if (strEQ(d,"uc"))                  return -KEY_uc;
4764             break;
4765         case 3:
4766             if (strEQ(d,"use"))                 return KEY_use;
4767             break;
4768         case 5:
4769             if (strEQ(d,"undef"))               return KEY_undef;
4770             if (strEQ(d,"until"))               return KEY_until;
4771             if (strEQ(d,"untie"))               return KEY_untie;
4772             if (strEQ(d,"utime"))               return -KEY_utime;
4773             if (strEQ(d,"umask"))               return -KEY_umask;
4774             break;
4775         case 6:
4776             if (strEQ(d,"unless"))              return KEY_unless;
4777             if (strEQ(d,"unpack"))              return -KEY_unpack;
4778             if (strEQ(d,"unlink"))              return -KEY_unlink;
4779             break;
4780         case 7:
4781             if (strEQ(d,"unshift"))             return KEY_unshift;
4782             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
4783             break;
4784         }
4785         break;
4786     case 'v':
4787         if (strEQ(d,"values"))                  return -KEY_values;
4788         if (strEQ(d,"vec"))                     return -KEY_vec;
4789         break;
4790     case 'w':
4791         switch (len) {
4792         case 4:
4793             if (strEQ(d,"warn"))                return -KEY_warn;
4794             if (strEQ(d,"wait"))                return -KEY_wait;
4795             break;
4796         case 5:
4797             if (strEQ(d,"while"))               return KEY_while;
4798             if (strEQ(d,"write"))               return -KEY_write;
4799             break;
4800         case 7:
4801             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
4802             break;
4803         case 9:
4804             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
4805             break;
4806         }
4807         break;
4808     case 'x':
4809         if (len == 1)                           return -KEY_x;
4810         if (strEQ(d,"xor"))                     return -KEY_xor;
4811         break;
4812     case 'y':
4813         if (len == 1)                           return KEY_y;
4814         break;
4815     case 'z':
4816         break;
4817     }
4818     return 0;
4819 }
4820
4821 STATIC void
4822 checkcomma(register char *s, char *name, char *what)
4823 {
4824     char *w;
4825
4826     if (ckWARN(WARN_SYNTAX) && *s == ' ' && s[1] == '(') {      /* XXX gotta be a better way */
4827         int level = 1;
4828         for (w = s+2; *w && level; w++) {
4829             if (*w == '(')
4830                 ++level;
4831             else if (*w == ')')
4832                 --level;
4833         }
4834         if (*w)
4835             for (; *w && isSPACE(*w); w++) ;
4836         if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
4837             warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4838     }
4839     while (s < PL_bufend && isSPACE(*s))
4840         s++;
4841     if (*s == '(')
4842         s++;
4843     while (s < PL_bufend && isSPACE(*s))
4844         s++;
4845     if (isIDFIRST(*s)) {
4846         w = s++;
4847         while (isALNUM(*s))
4848             s++;
4849         while (s < PL_bufend && isSPACE(*s))
4850             s++;
4851         if (*s == ',') {
4852             int kw;
4853             *s = '\0';
4854             kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4855             *s = ',';
4856             if (kw)
4857                 return;
4858             croak("No comma allowed after %s", what);
4859         }
4860     }
4861 }
4862
4863 STATIC SV *
4864 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4865 {
4866     dSP;
4867     HV *table = GvHV(PL_hintgv);                 /* ^H */
4868     BINOP myop;
4869     SV *res;
4870     bool oldcatch = CATCH_GET;
4871     SV **cvp;
4872     SV *cv, *typesv;
4873     char buf[128];
4874
4875     if (!table) {
4876         yyerror("%^H is not defined");
4877         return sv;
4878     }
4879     cvp = hv_fetch(table, key, strlen(key), FALSE);
4880     if (!cvp || !SvOK(*cvp)) {
4881         sprintf(buf,"$^H{%s} is not defined", key);
4882         yyerror(buf);
4883         return sv;
4884     }
4885     sv_2mortal(sv);                     /* Parent created it permanently */
4886     cv = *cvp;
4887     if (!pv)
4888         pv = sv_2mortal(newSVpv(s, len));
4889     if (type)
4890         typesv = sv_2mortal(newSVpv(type, 0));
4891     else
4892         typesv = &PL_sv_undef;
4893     CATCH_SET(TRUE);
4894     Zero(&myop, 1, BINOP);
4895     myop.op_last = (OP *) &myop;
4896     myop.op_next = Nullop;
4897     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4898
4899     PUSHSTACKi(PERLSI_OVERLOAD);
4900     ENTER;
4901     SAVEOP();
4902     PL_op = (OP *) &myop;
4903     if (PERLDB_SUB && PL_curstash != PL_debstash)
4904         PL_op->op_private |= OPpENTERSUB_DB;
4905     PUTBACK;
4906     pp_pushmark(ARGS);
4907
4908     EXTEND(sp, 4);
4909     PUSHs(pv);
4910     PUSHs(sv);
4911     PUSHs(typesv);
4912     PUSHs(cv);
4913     PUTBACK;
4914
4915     if (PL_op = pp_entersub(ARGS))
4916       CALLRUNOPS();
4917     LEAVE;
4918     SPAGAIN;
4919
4920     res = POPs;
4921     PUTBACK;
4922     CATCH_SET(oldcatch);
4923     POPSTACK;
4924
4925     if (!SvOK(res)) {
4926         sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
4927         yyerror(buf);
4928     }
4929     return SvREFCNT_inc(res);
4930 }
4931
4932 STATIC char *
4933 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
4934 {
4935     register char *d = dest;
4936     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
4937     for (;;) {
4938         if (d >= e)
4939             croak(ident_too_long);
4940         if (isALNUM(*s))
4941             *d++ = *s++;
4942         else if (*s == '\'' && allow_package && isIDFIRST(s[1])) {
4943             *d++ = ':';
4944             *d++ = ':';
4945             s++;
4946         }
4947         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
4948             *d++ = *s++;
4949             *d++ = *s++;
4950         }
4951         else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8(s)) {
4952             char *t = s + UTF8SKIP(s);
4953             while (*t & 0x80 && is_utf8_mark(t))
4954                 t += UTF8SKIP(t);
4955             if (d + (t - s) > e)
4956                 croak(ident_too_long);
4957             Copy(s, d, t - s, char);
4958             d += t - s;
4959             s = t;
4960         }
4961         else {
4962             *d = '\0';
4963             *slp = d - dest;
4964             return s;
4965         }
4966     }
4967 }
4968
4969 STATIC char *
4970 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
4971 {
4972     register char *d;
4973     register char *e;
4974     char *bracket = 0;
4975     char funny = *s++;
4976
4977     if (PL_lex_brackets == 0)
4978         PL_lex_fakebrack = 0;
4979     if (isSPACE(*s))
4980         s = skipspace(s);
4981     d = dest;
4982     e = d + destlen - 3;        /* two-character token, ending NUL */
4983     if (isDIGIT(*s)) {
4984         while (isDIGIT(*s)) {
4985             if (d >= e)
4986                 croak(ident_too_long);
4987             *d++ = *s++;
4988         }
4989     }
4990     else {
4991         for (;;) {
4992             if (d >= e)
4993                 croak(ident_too_long);
4994             if (isALNUM(*s))
4995                 *d++ = *s++;
4996             else if (*s == '\'' && isIDFIRST(s[1])) {
4997                 *d++ = ':';
4998                 *d++ = ':';
4999                 s++;
5000             }
5001             else if (*s == ':' && s[1] == ':') {
5002                 *d++ = *s++;
5003                 *d++ = *s++;
5004             }
5005             else if (UTF && (*s & 0xc0) == 0x80 && isALNUM_utf8(s)) {
5006                 char *t = s + UTF8SKIP(s);
5007                 while (*t & 0x80 && is_utf8_mark(t))
5008                     t += UTF8SKIP(t);
5009                 if (d + (t - s) > e)
5010                     croak(ident_too_long);
5011                 Copy(s, d, t - s, char);
5012                 d += t - s;
5013                 s = t;
5014             }
5015             else
5016                 break;
5017         }
5018     }
5019     *d = '\0';
5020     d = dest;
5021     if (*d) {
5022         if (PL_lex_state != LEX_NORMAL)
5023             PL_lex_state = LEX_INTERPENDMAYBE;
5024         return s;
5025     }
5026     if (*s == '$' && s[1] &&
5027       (isALNUM(s[1]) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5028     {
5029         if (isDIGIT(s[1]) && PL_lex_state == LEX_INTERPNORMAL)
5030             deprecate("\"$$<digit>\" to mean \"${$}<digit>\"");
5031         else
5032             return s;
5033     }
5034     if (*s == '{') {
5035         bracket = s;
5036         s++;
5037     }
5038     else if (ck_uni)
5039         check_uni();
5040     if (s < send)
5041         *d = *s++;
5042     d[1] = '\0';
5043     if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5044         *d = toCTRL(*s);
5045         s++;
5046     }
5047     if (bracket) {
5048         if (isSPACE(s[-1])) {
5049             while (s < send) {
5050                 char ch = *s++;
5051                 if (ch != ' ' && ch != '\t') {
5052                     *d = ch;
5053                     break;
5054                 }
5055             }
5056         }
5057         if (isIDFIRST(*d) || (UTF && (*d & 0xc0) == 0x80 && isIDFIRST_utf8(d))) {
5058             d++;
5059             if (UTF) {
5060                 e = s;
5061                 while (e < send && (isALNUM(*e) || ((*e & 0xc0) == 0x80 && isALNUM_utf8((U8*)e)) || *e == ':')) {
5062                     e += UTF8SKIP(e);
5063                     while (e < send && *e & 0x80 && is_utf8_mark(e))
5064                         e += UTF8SKIP(e);
5065                 }
5066                 Copy(s, d, e - s, char);
5067                 d += e - s;
5068                 s = e;
5069             }
5070             else {
5071                 while (isALNUM(*s) || *s == ':')
5072                     *d++ = *s++;
5073             }
5074             *d = '\0';
5075             while (s < send && (*s == ' ' || *s == '\t')) s++;
5076             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5077                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5078                     char *brack = *s == '[' ? "[...]" : "{...}";
5079                     warner(WARN_AMBIGUOUS,
5080                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5081                         funny, dest, brack, funny, dest, brack);
5082                 }
5083                 PL_lex_fakebrack = PL_lex_brackets+1;
5084                 bracket++;
5085                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5086                 return s;
5087             }
5088         }
5089         if (*s == '}') {
5090             s++;
5091             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5092                 PL_lex_state = LEX_INTERPEND;
5093             if (funny == '#')
5094                 funny = '@';
5095             if (ckWARN(WARN_AMBIGUOUS) && PL_lex_state == LEX_NORMAL &&
5096               (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5097                 warner(WARN_AMBIGUOUS,
5098                     "Ambiguous use of %c{%s} resolved to %c%s",
5099                     funny, dest, funny, dest);
5100         }
5101         else {
5102             s = bracket;                /* let the parser handle it */
5103             *dest = '\0';
5104         }
5105     }
5106     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5107         PL_lex_state = LEX_INTERPEND;
5108     return s;
5109 }
5110
5111 void pmflag(U16 *pmfl, int ch)
5112 {
5113     if (ch == 'i')
5114         *pmfl |= PMf_FOLD;
5115     else if (ch == 'g')
5116         *pmfl |= PMf_GLOBAL;
5117     else if (ch == 'c')
5118         *pmfl |= PMf_CONTINUE;
5119     else if (ch == 'o')
5120         *pmfl |= PMf_KEEP;
5121     else if (ch == 'm')
5122         *pmfl |= PMf_MULTILINE;
5123     else if (ch == 's')
5124         *pmfl |= PMf_SINGLELINE;
5125     else if (ch == 'x')
5126         *pmfl |= PMf_EXTENDED;
5127 }
5128
5129 STATIC char *
5130 scan_pat(char *start, I32 type)
5131 {
5132     PMOP *pm;
5133     char *s;
5134
5135     s = scan_str(start);
5136     if (!s) {
5137         if (PL_lex_stuff)
5138             SvREFCNT_dec(PL_lex_stuff);
5139         PL_lex_stuff = Nullsv;
5140         croak("Search pattern not terminated");
5141     }
5142
5143     pm = (PMOP*)newPMOP(type, 0);
5144     if (PL_multi_open == '?')
5145         pm->op_pmflags |= PMf_ONCE;
5146     if(type == OP_QR) {
5147         while (*s && strchr("iomsx", *s))
5148             pmflag(&pm->op_pmflags,*s++);
5149     }
5150     else {
5151         while (*s && strchr("iogcmsx", *s))
5152             pmflag(&pm->op_pmflags,*s++);
5153     }
5154     pm->op_pmpermflags = pm->op_pmflags;
5155
5156     PL_lex_op = (OP*)pm;
5157     yylval.ival = OP_MATCH;
5158     return s;
5159 }
5160
5161 STATIC char *
5162 scan_subst(char *start)
5163 {
5164     register char *s;
5165     register PMOP *pm;
5166     I32 first_start;
5167     I32 es = 0;
5168
5169     yylval.ival = OP_NULL;
5170
5171     s = scan_str(start);
5172
5173     if (!s) {
5174         if (PL_lex_stuff)
5175             SvREFCNT_dec(PL_lex_stuff);
5176         PL_lex_stuff = Nullsv;
5177         croak("Substitution pattern not terminated");
5178     }
5179
5180     if (s[-1] == PL_multi_open)
5181         s--;
5182
5183     first_start = PL_multi_start;
5184     s = scan_str(s);
5185     if (!s) {
5186         if (PL_lex_stuff)
5187             SvREFCNT_dec(PL_lex_stuff);
5188         PL_lex_stuff = Nullsv;
5189         if (PL_lex_repl)
5190             SvREFCNT_dec(PL_lex_repl);
5191         PL_lex_repl = Nullsv;
5192         croak("Substitution replacement not terminated");
5193     }
5194     PL_multi_start = first_start;       /* so whole substitution is taken together */
5195
5196     pm = (PMOP*)newPMOP(OP_SUBST, 0);
5197     while (*s) {
5198         if (*s == 'e') {
5199             s++;
5200             es++;
5201         }
5202         else if (strchr("iogcmsx", *s))
5203             pmflag(&pm->op_pmflags,*s++);
5204         else
5205             break;
5206     }
5207
5208     if (es) {
5209         SV *repl;
5210         pm->op_pmflags |= PMf_EVAL;
5211         repl = newSVpv("",0);
5212         while (es-- > 0)
5213             sv_catpv(repl, es ? "eval " : "do ");
5214         sv_catpvn(repl, "{ ", 2);
5215         sv_catsv(repl, PL_lex_repl);
5216         sv_catpvn(repl, " };", 2);
5217         SvCOMPILED_on(repl);
5218         SvREFCNT_dec(PL_lex_repl);
5219         PL_lex_repl = repl;
5220     }
5221
5222     pm->op_pmpermflags = pm->op_pmflags;
5223     PL_lex_op = (OP*)pm;
5224     yylval.ival = OP_SUBST;
5225     return s;
5226 }
5227
5228 STATIC char *
5229 scan_trans(char *start)
5230 {
5231     register char* s;
5232     OP *o;
5233     short *tbl;
5234     I32 squash;
5235     I32 del;
5236     I32 complement;
5237     I32 utf8;
5238     I32 count = 0;
5239
5240     yylval.ival = OP_NULL;
5241
5242     s = scan_str(start);
5243     if (!s) {
5244         if (PL_lex_stuff)
5245             SvREFCNT_dec(PL_lex_stuff);
5246         PL_lex_stuff = Nullsv;
5247         croak("Transliteration pattern not terminated");
5248     }
5249     if (s[-1] == PL_multi_open)
5250         s--;
5251
5252     s = scan_str(s);
5253     if (!s) {
5254         if (PL_lex_stuff)
5255             SvREFCNT_dec(PL_lex_stuff);
5256         PL_lex_stuff = Nullsv;
5257         if (PL_lex_repl)
5258             SvREFCNT_dec(PL_lex_repl);
5259         PL_lex_repl = Nullsv;
5260         croak("Transliteration replacement not terminated");
5261     }
5262
5263     if (UTF) {
5264         o = newSVOP(OP_TRANS, 0, 0);
5265         utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5266     }
5267     else {
5268         New(803,tbl,256,short);
5269         o = newPVOP(OP_TRANS, 0, (char*)tbl);
5270         utf8 = 0;
5271     }
5272
5273     complement = del = squash = 0;
5274     while (strchr("cdsCU", *s)) {
5275         if (*s == 'c')
5276             complement = OPpTRANS_COMPLEMENT;
5277         else if (*s == 'd')
5278             del = OPpTRANS_DELETE;
5279         else if (*s == 's')
5280             squash = OPpTRANS_SQUASH;
5281         else {
5282             switch (count++) {
5283             case 0:
5284                 if (*s == 'C')
5285                     utf8 &= ~OPpTRANS_FROM_UTF;
5286                 else
5287                     utf8 |= OPpTRANS_FROM_UTF;
5288                 break;
5289             case 1:
5290                 if (*s == 'C')
5291                     utf8 &= ~OPpTRANS_TO_UTF;
5292                 else
5293                     utf8 |= OPpTRANS_TO_UTF;
5294                 break;
5295             default:
5296                 croak("Too many /C and /U options");
5297             }
5298         }
5299         s++;
5300     }
5301     o->op_private = del|squash|complement|utf8;
5302
5303     PL_lex_op = o;
5304     yylval.ival = OP_TRANS;
5305     return s;
5306 }
5307
5308 STATIC char *
5309 scan_heredoc(register char *s)
5310 {
5311     dTHR;
5312     SV *herewas;
5313     I32 op_type = OP_SCALAR;
5314     I32 len;
5315     SV *tmpstr;
5316     char term;
5317     register char *d;
5318     register char *e;
5319     char *peek;
5320     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5321
5322     s += 2;
5323     d = PL_tokenbuf;
5324     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5325     if (!outer)
5326         *d++ = '\n';
5327     for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5328     if (*peek && strchr("`'\"",*peek)) {
5329         s = peek;
5330         term = *s++;
5331         s = delimcpy(d, e, s, PL_bufend, term, &len);
5332         d += len;
5333         if (s < PL_bufend)
5334             s++;
5335     }
5336     else {
5337         if (*s == '\\')
5338             s++, term = '\'';
5339         else
5340             term = '"';
5341         if (!isALNUM(*s))
5342             deprecate("bare << to mean <<\"\"");
5343         for (; isALNUM(*s); s++) {
5344             if (d < e)
5345                 *d++ = *s;
5346         }
5347     }
5348     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5349         croak("Delimiter for here document is too long");
5350     *d++ = '\n';
5351     *d = '\0';
5352     len = d - PL_tokenbuf;
5353 #ifndef PERL_STRICT_CR
5354     d = strchr(s, '\r');
5355     if (d) {
5356         char *olds = s;
5357         s = d;
5358         while (s < PL_bufend) {
5359             if (*s == '\r') {
5360                 *d++ = '\n';
5361                 if (*++s == '\n')
5362                     s++;
5363             }
5364             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
5365                 *d++ = *s++;
5366                 s++;
5367             }
5368             else
5369                 *d++ = *s++;
5370         }
5371         *d = '\0';
5372         PL_bufend = d;
5373         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5374         s = olds;
5375     }
5376 #endif
5377     d = "\n";
5378     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5379         herewas = newSVpv(s,PL_bufend-s);
5380     else
5381         s--, herewas = newSVpv(s,d-s);
5382     s += SvCUR(herewas);
5383
5384     tmpstr = NEWSV(87,79);
5385     sv_upgrade(tmpstr, SVt_PVIV);
5386     if (term == '\'') {
5387         op_type = OP_CONST;
5388         SvIVX(tmpstr) = -1;
5389     }
5390     else if (term == '`') {
5391         op_type = OP_BACKTICK;
5392         SvIVX(tmpstr) = '\\';
5393     }
5394
5395     CLINE;
5396     PL_multi_start = PL_curcop->cop_line;
5397     PL_multi_open = PL_multi_close = '<';
5398     term = *PL_tokenbuf;
5399     if (!outer) {
5400         d = s;
5401         while (s < PL_bufend &&
5402           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5403             if (*s++ == '\n')
5404                 PL_curcop->cop_line++;
5405         }
5406         if (s >= PL_bufend) {
5407             PL_curcop->cop_line = PL_multi_start;
5408             missingterm(PL_tokenbuf);
5409         }
5410         sv_setpvn(tmpstr,d+1,s-d);
5411         s += len - 1;
5412         PL_curcop->cop_line++;  /* the preceding stmt passes a newline */
5413
5414         sv_catpvn(herewas,s,PL_bufend-s);
5415         sv_setsv(PL_linestr,herewas);
5416         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5417         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5418     }
5419     else
5420         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
5421     while (s >= PL_bufend) {    /* multiple line string? */
5422         if (!outer ||
5423          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5424             PL_curcop->cop_line = PL_multi_start;
5425             missingterm(PL_tokenbuf);
5426         }
5427         PL_curcop->cop_line++;
5428         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5429 #ifndef PERL_STRICT_CR
5430         if (PL_bufend - PL_linestart >= 2) {
5431             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5432                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5433             {
5434                 PL_bufend[-2] = '\n';
5435                 PL_bufend--;
5436                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5437             }
5438             else if (PL_bufend[-1] == '\r')
5439                 PL_bufend[-1] = '\n';
5440         }
5441         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5442             PL_bufend[-1] = '\n';
5443 #endif
5444         if (PERLDB_LINE && PL_curstash != PL_debstash) {
5445             SV *sv = NEWSV(88,0);
5446
5447             sv_upgrade(sv, SVt_PVMG);
5448             sv_setsv(sv,PL_linestr);
5449             av_store(GvAV(PL_curcop->cop_filegv),
5450               (I32)PL_curcop->cop_line,sv);
5451         }
5452         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5453             s = PL_bufend - 1;
5454             *s = ' ';
5455             sv_catsv(PL_linestr,herewas);
5456             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5457         }
5458         else {
5459             s = PL_bufend;
5460             sv_catsv(tmpstr,PL_linestr);
5461         }
5462     }
5463     PL_multi_end = PL_curcop->cop_line;
5464     s++;
5465     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5466         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5467         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5468     }
5469     SvREFCNT_dec(herewas);
5470     PL_lex_stuff = tmpstr;
5471     yylval.ival = op_type;
5472     return s;
5473 }
5474
5475 /* scan_inputsymbol
5476    takes: current position in input buffer
5477    returns: new position in input buffer
5478    side-effects: yylval and lex_op are set.
5479
5480    This code handles:
5481
5482    <>           read from ARGV
5483    <FH>         read from filehandle
5484    <pkg::FH>    read from package qualified filehandle
5485    <pkg'FH>     read from package qualified filehandle
5486    <$fh>        read from filehandle in $fh
5487    <*.h>        filename glob
5488
5489 */
5490
5491 STATIC char *
5492 scan_inputsymbol(char *start)
5493 {
5494     register char *s = start;           /* current position in buffer */
5495     register char *d;
5496     register char *e;
5497     I32 len;
5498
5499     d = PL_tokenbuf;                    /* start of temp holding space */
5500     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
5501     s = delimcpy(d, e, s + 1, PL_bufend, '>', &len);    /* extract until > */
5502
5503     /* die if we didn't have space for the contents of the <>,
5504        or if it didn't end
5505     */
5506
5507     if (len >= sizeof PL_tokenbuf)
5508         croak("Excessively long <> operator");
5509     if (s >= PL_bufend)
5510         croak("Unterminated <> operator");
5511
5512     s++;
5513
5514     /* check for <$fh>
5515        Remember, only scalar variables are interpreted as filehandles by
5516        this code.  Anything more complex (e.g., <$fh{$num}>) will be
5517        treated as a glob() call.
5518        This code makes use of the fact that except for the $ at the front,
5519        a scalar variable and a filehandle look the same.
5520     */
5521     if (*d == '$' && d[1]) d++;
5522
5523     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5524     while (*d && (isALNUM(*d) || *d == '\'' || *d == ':'))
5525         d++;
5526
5527     /* If we've tried to read what we allow filehandles to look like, and
5528        there's still text left, then it must be a glob() and not a getline.
5529        Use scan_str to pull out the stuff between the <> and treat it
5530        as nothing more than a string.
5531     */
5532
5533     if (d - PL_tokenbuf != len) {
5534         yylval.ival = OP_GLOB;
5535         set_csh();
5536         s = scan_str(start);
5537         if (!s)
5538            croak("Glob not terminated");
5539         return s;
5540     }
5541     else {
5542         /* we're in a filehandle read situation */
5543         d = PL_tokenbuf;
5544
5545         /* turn <> into <ARGV> */
5546         if (!len)
5547             (void)strcpy(d,"ARGV");
5548
5549         /* if <$fh>, create the ops to turn the variable into a
5550            filehandle
5551         */
5552         if (*d == '$') {
5553             I32 tmp;
5554
5555             /* try to find it in the pad for this block, otherwise find
5556                add symbol table ops
5557             */
5558             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5559                 OP *o = newOP(OP_PADSV, 0);
5560                 o->op_targ = tmp;
5561                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5562             }
5563             else {
5564                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5565                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5566                                         newUNOP(OP_RV2GV, 0,
5567                                             newUNOP(OP_RV2SV, 0,
5568                                                 newGVOP(OP_GV, 0, gv))));
5569             }
5570             /* we created the ops in lex_op, so make yylval.ival a null op */
5571             yylval.ival = OP_NULL;
5572         }
5573
5574         /* If it's none of the above, it must be a literal filehandle
5575            (<Foo::BAR> or <FOO>) so build a simple readline OP */
5576         else {
5577             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5578             PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5579             yylval.ival = OP_NULL;
5580         }
5581     }
5582
5583     return s;
5584 }
5585
5586
5587 /* scan_str
5588    takes: start position in buffer
5589    returns: position to continue reading from buffer
5590    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5591         updates the read buffer.
5592
5593    This subroutine pulls a string out of the input.  It is called for:
5594         q               single quotes           q(literal text)
5595         '               single quotes           'literal text'
5596         qq              double quotes           qq(interpolate $here please)
5597         "               double quotes           "interpolate $here please"
5598         qx              backticks               qx(/bin/ls -l)
5599         `               backticks               `/bin/ls -l`
5600         qw              quote words             @EXPORT_OK = qw( func() $spam )
5601         m//             regexp match            m/this/
5602         s///            regexp substitute       s/this/that/
5603         tr///           string transliterate    tr/this/that/
5604         y///            string transliterate    y/this/that/
5605         ($*@)           sub prototypes          sub foo ($)
5606         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
5607
5608    In most of these cases (all but <>, patterns and transliterate)
5609    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
5610    calls scan_str().  s/// makes yylex() call scan_subst() which calls
5611    scan_str().  tr/// and y/// make yylex() call scan_trans() which
5612    calls scan_str().
5613
5614    It skips whitespace before the string starts, and treats the first
5615    character as the delimiter.  If the delimiter is one of ([{< then
5616    the corresponding "close" character )]}> is used as the closing
5617    delimiter.  It allows quoting of delimiters, and if the string has
5618    balanced delimiters ([{<>}]) it allows nesting.
5619
5620    The lexer always reads these strings into lex_stuff, except in the
5621    case of the operators which take *two* arguments (s/// and tr///)
5622    when it checks to see if lex_stuff is full (presumably with the 1st
5623    arg to s or tr) and if so puts the string into lex_repl.
5624
5625 */
5626
5627 STATIC char *
5628 scan_str(char *start)
5629 {
5630     dTHR;
5631     SV *sv;                             /* scalar value: string */
5632     char *tmps;                         /* temp string, used for delimiter matching */
5633     register char *s = start;           /* current position in the buffer */
5634     register char term;                 /* terminating character */
5635     register char *to;                  /* current position in the sv's data */
5636     I32 brackets = 1;                   /* bracket nesting level */
5637
5638     /* skip space before the delimiter */
5639     if (isSPACE(*s))
5640         s = skipspace(s);
5641
5642     /* mark where we are, in case we need to report errors */
5643     CLINE;
5644
5645     /* after skipping whitespace, the next character is the terminator */
5646     term = *s;
5647     /* mark where we are */
5648     PL_multi_start = PL_curcop->cop_line;
5649     PL_multi_open = term;
5650
5651     /* find corresponding closing delimiter */
5652     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5653         term = tmps[5];
5654     PL_multi_close = term;
5655
5656     /* create a new SV to hold the contents.  87 is leak category, I'm
5657        assuming.  79 is the SV's initial length.  What a random number. */
5658     sv = NEWSV(87,79);
5659     sv_upgrade(sv, SVt_PVIV);
5660     SvIVX(sv) = term;
5661     (void)SvPOK_only(sv);               /* validate pointer */
5662
5663     /* move past delimiter and try to read a complete string */
5664     s++;
5665     for (;;) {
5666         /* extend sv if need be */
5667         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5668         /* set 'to' to the next character in the sv's string */
5669         to = SvPVX(sv)+SvCUR(sv);
5670
5671         /* if open delimiter is the close delimiter read unbridle */
5672         if (PL_multi_open == PL_multi_close) {
5673             for (; s < PL_bufend; s++,to++) {
5674                 /* embedded newlines increment the current line number */
5675                 if (*s == '\n' && !PL_rsfp)
5676                     PL_curcop->cop_line++;
5677                 /* handle quoted delimiters */
5678                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5679                     if (s[1] == term)
5680                         s++;
5681                 /* any other quotes are simply copied straight through */
5682                     else
5683                         *to++ = *s++;
5684                 }
5685                 /* terminate when run out of buffer (the for() condition), or
5686                    have found the terminator */
5687                 else if (*s == term)
5688                     break;
5689                 *to = *s;
5690             }
5691         }
5692
5693         /* if the terminator isn't the same as the start character (e.g.,
5694            matched brackets), we have to allow more in the quoting, and
5695            be prepared for nested brackets.
5696         */
5697         else {
5698             /* read until we run out of string, or we find the terminator */
5699             for (; s < PL_bufend; s++,to++) {
5700                 /* embedded newlines increment the line count */
5701                 if (*s == '\n' && !PL_rsfp)
5702                     PL_curcop->cop_line++;
5703                 /* backslashes can escape the open or closing characters */
5704                 if (*s == '\\' && s+1 < PL_bufend) {
5705                     if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5706                         s++;
5707                     else
5708                         *to++ = *s++;
5709                 }
5710                 /* allow nested opens and closes */
5711                 else if (*s == PL_multi_close && --brackets <= 0)
5712                     break;
5713                 else if (*s == PL_multi_open)
5714                     brackets++;
5715                 *to = *s;
5716             }
5717         }
5718         /* terminate the copied string and update the sv's end-of-string */
5719         *to = '\0';
5720         SvCUR_set(sv, to - SvPVX(sv));
5721
5722         /*
5723          * this next chunk reads more into the buffer if we're not done yet
5724          */
5725
5726         if (s < PL_bufend) break;       /* handle case where we are done yet :-) */
5727
5728 #ifndef PERL_STRICT_CR
5729         if (to - SvPVX(sv) >= 2) {
5730             if ((to[-2] == '\r' && to[-1] == '\n') ||
5731                 (to[-2] == '\n' && to[-1] == '\r'))
5732             {
5733                 to[-2] = '\n';
5734                 to--;
5735                 SvCUR_set(sv, to - SvPVX(sv));
5736             }
5737             else if (to[-1] == '\r')
5738                 to[-1] = '\n';
5739         }
5740         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5741             to[-1] = '\n';
5742 #endif
5743
5744         /* if we're out of file, or a read fails, bail and reset the current
5745            line marker so we can report where the unterminated string began
5746         */
5747         if (!PL_rsfp ||
5748          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5749             sv_free(sv);
5750             PL_curcop->cop_line = PL_multi_start;
5751             return Nullch;
5752         }
5753         /* we read a line, so increment our line counter */
5754         PL_curcop->cop_line++;
5755
5756         /* update debugger info */
5757         if (PERLDB_LINE && PL_curstash != PL_debstash) {
5758             SV *sv = NEWSV(88,0);
5759
5760             sv_upgrade(sv, SVt_PVMG);
5761             sv_setsv(sv,PL_linestr);
5762             av_store(GvAV(PL_curcop->cop_filegv),
5763               (I32)PL_curcop->cop_line, sv);
5764         }
5765
5766         /* having changed the buffer, we must update PL_bufend */
5767         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5768     }
5769
5770     /* at this point, we have successfully read the delimited string */
5771
5772     PL_multi_end = PL_curcop->cop_line;
5773     s++;
5774
5775     /* if we allocated too much space, give some back */
5776     if (SvCUR(sv) + 5 < SvLEN(sv)) {
5777         SvLEN_set(sv, SvCUR(sv) + 1);
5778         Renew(SvPVX(sv), SvLEN(sv), char);
5779     }
5780
5781     /* decide whether this is the first or second quoted string we've read
5782        for this op
5783     */
5784
5785     if (PL_lex_stuff)
5786         PL_lex_repl = sv;
5787     else
5788         PL_lex_stuff = sv;
5789     return s;
5790 }
5791
5792 /*
5793   scan_num
5794   takes: pointer to position in buffer
5795   returns: pointer to new position in buffer
5796   side-effects: builds ops for the constant in yylval.op
5797
5798   Read a number in any of the formats that Perl accepts:
5799
5800   0(x[0-7A-F]+)|([0-7]+)
5801   [\d_]+(\.[\d_]*)?[Ee](\d+)
5802
5803   Underbars (_) are allowed in decimal numbers.  If -w is on,
5804   underbars before a decimal point must be at three digit intervals.
5805
5806   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5807   thing it reads.
5808
5809   If it reads a number without a decimal point or an exponent, it will
5810   try converting the number to an integer and see if it can do so
5811   without loss of precision.
5812 */
5813
5814 char *
5815 scan_num(char *start)
5816 {
5817     register char *s = start;           /* current position in buffer */
5818     register char *d;                   /* destination in temp buffer */
5819     register char *e;                   /* end of temp buffer */
5820     I32 tryiv;                          /* used to see if it can be an int */
5821     double value;                       /* number read, as a double */
5822     SV *sv;                             /* place to put the converted number */
5823     I32 floatit;                        /* boolean: int or float? */
5824     char *lastub = 0;                   /* position of last underbar */
5825     static char number_too_long[] = "Number too long";
5826
5827     /* We use the first character to decide what type of number this is */
5828
5829     switch (*s) {
5830     default:
5831       croak("panic: scan_num");
5832
5833     /* if it starts with a 0, it could be an octal number, a decimal in
5834        0.13 disguise, or a hexadecimal number.
5835     */
5836     case '0':
5837         {
5838           /* variables:
5839              u          holds the "number so far"
5840              shift      the power of 2 of the base (hex == 4, octal == 3)
5841              overflowed was the number more than we can hold?
5842
5843              Shift is used when we add a digit.  It also serves as an "are
5844              we in octal or hex?" indicator to disallow hex characters when
5845              in octal mode.
5846            */
5847             UV u;
5848             I32 shift;
5849             bool overflowed = FALSE;
5850
5851             /* check for hex */
5852             if (s[1] == 'x') {
5853                 shift = 4;
5854                 s += 2;
5855             }
5856             /* check for a decimal in disguise */
5857             else if (s[1] == '.')
5858                 goto decimal;
5859             /* so it must be octal */
5860             else
5861                 shift = 3;
5862             u = 0;
5863
5864             /* read the rest of the octal number */
5865             for (;;) {
5866                 UV n, b;        /* n is used in the overflow test, b is the digit we're adding on */
5867
5868                 switch (*s) {
5869
5870                 /* if we don't mention it, we're done */
5871                 default:
5872                     goto out;
5873
5874                 /* _ are ignored */
5875                 case '_':
5876                     s++;
5877                     break;
5878
5879                 /* 8 and 9 are not octal */
5880                 case '8': case '9':
5881                     if (shift != 4)
5882                         yyerror("Illegal octal digit");
5883                     /* FALL THROUGH */
5884
5885                 /* octal digits */
5886                 case '0': case '1': case '2': case '3': case '4':
5887                 case '5': case '6': case '7':
5888                     b = *s++ & 15;              /* ASCII digit -> value of digit */
5889                     goto digit;
5890
5891                 /* hex digits */
5892                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5893                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5894                     /* make sure they said 0x */
5895                     if (shift != 4)
5896                         goto out;
5897                     b = (*s++ & 7) + 9;
5898
5899                     /* Prepare to put the digit we have onto the end
5900                        of the number so far.  We check for overflows.
5901                     */
5902
5903                   digit:
5904                     n = u << shift;     /* make room for the digit */
5905                     if (!overflowed && (n >> shift) != u
5906                         && !(PL_hints & HINT_NEW_BINARY)) {
5907                         warn("Integer overflow in %s number",
5908                              (shift == 4) ? "hex" : "octal");
5909                         overflowed = TRUE;
5910                     }
5911                     u = n | b;          /* add the digit to the end */
5912                     break;
5913                 }
5914             }
5915
5916           /* if we get here, we had success: make a scalar value from
5917              the number.
5918           */
5919           out:
5920             sv = NEWSV(92,0);
5921             sv_setuv(sv, u);
5922             if ( PL_hints & HINT_NEW_BINARY)
5923                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
5924         }
5925         break;
5926
5927     /*
5928       handle decimal numbers.
5929       we're also sent here when we read a 0 as the first digit
5930     */
5931     case '1': case '2': case '3': case '4': case '5':
5932     case '6': case '7': case '8': case '9': case '.':
5933       decimal:
5934         d = PL_tokenbuf;
5935         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
5936         floatit = FALSE;
5937
5938         /* read next group of digits and _ and copy into d */
5939         while (isDIGIT(*s) || *s == '_') {
5940             /* skip underscores, checking for misplaced ones
5941                if -w is on
5942             */
5943             if (*s == '_') {
5944                 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
5945                     warner(WARN_SYNTAX, "Misplaced _ in number");
5946                 lastub = ++s;
5947             }
5948             else {
5949                 /* check for end of fixed-length buffer */
5950                 if (d >= e)
5951                     croak(number_too_long);
5952                 /* if we're ok, copy the character */
5953                 *d++ = *s++;
5954             }
5955         }
5956
5957         /* final misplaced underbar check */
5958         if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
5959             warner(WARN_SYNTAX, "Misplaced _ in number");
5960
5961         /* read a decimal portion if there is one.  avoid
5962            3..5 being interpreted as the number 3. followed
5963            by .5
5964         */
5965         if (*s == '.' && s[1] != '.') {
5966             floatit = TRUE;
5967             *d++ = *s++;
5968
5969             /* copy, ignoring underbars, until we run out of
5970                digits.  Note: no misplaced underbar checks!
5971             */
5972             for (; isDIGIT(*s) || *s == '_'; s++) {
5973                 /* fixed length buffer check */
5974                 if (d >= e)
5975                     croak(number_too_long);
5976                 if (*s != '_')
5977                     *d++ = *s;
5978             }
5979         }
5980
5981         /* read exponent part, if present */
5982         if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
5983             floatit = TRUE;
5984             s++;
5985
5986             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
5987             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
5988
5989             /* allow positive or negative exponent */
5990             if (*s == '+' || *s == '-')
5991                 *d++ = *s++;
5992
5993             /* read digits of exponent (no underbars :-) */
5994             while (isDIGIT(*s)) {
5995                 if (d >= e)
5996                     croak(number_too_long);
5997                 *d++ = *s++;
5998             }
5999         }
6000
6001         /* terminate the string */
6002         *d = '\0';
6003
6004         /* make an sv from the string */
6005         sv = NEWSV(92,0);
6006         /* reset numeric locale in case we were earlier left in Swaziland */
6007         SET_NUMERIC_STANDARD();
6008         value = atof(PL_tokenbuf);
6009
6010         /*
6011            See if we can make do with an integer value without loss of
6012            precision.  We use I_V to cast to an int, because some
6013            compilers have issues.  Then we try casting it back and see
6014            if it was the same.  We only do this if we know we
6015            specifically read an integer.
6016
6017            Note: if floatit is true, then we don't need to do the
6018            conversion at all.
6019         */
6020         tryiv = I_V(value);
6021         if (!floatit && (double)tryiv == value)
6022             sv_setiv(sv, tryiv);
6023         else
6024             sv_setnv(sv, value);
6025         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6026             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6027                               (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6028         break;
6029     }
6030
6031     /* make the op for the constant and return */
6032
6033     yylval.opval = newSVOP(OP_CONST, 0, sv);
6034
6035     return s;
6036 }
6037
6038 STATIC char *
6039 scan_formline(register char *s)
6040 {
6041     dTHR;
6042     register char *eol;
6043     register char *t;
6044     SV *stuff = newSVpv("",0);
6045     bool needargs = FALSE;
6046
6047     while (!needargs) {
6048         if (*s == '.' || *s == '}') {
6049             /*SUPPRESS 530*/
6050             for (t = s+1; *t == ' ' || *t == '\t'; t++) ;
6051             if (*t == '\n')
6052                 break;
6053         }
6054         if (PL_in_eval && !PL_rsfp) {
6055             eol = strchr(s,'\n');
6056             if (!eol++)
6057                 eol = PL_bufend;
6058         }
6059         else
6060             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6061         if (*s != '#') {
6062             for (t = s; t < eol; t++) {
6063                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6064                     needargs = FALSE;
6065                     goto enough;        /* ~~ must be first line in formline */
6066                 }
6067                 if (*t == '@' || *t == '^')
6068                     needargs = TRUE;
6069             }
6070             sv_catpvn(stuff, s, eol-s);
6071         }
6072         s = eol;
6073         if (PL_rsfp) {
6074             s = filter_gets(PL_linestr, PL_rsfp, 0);
6075             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6076             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6077             if (!s) {
6078                 s = PL_bufptr;
6079                 yyerror("Format not terminated");
6080                 break;
6081             }
6082         }
6083         incline(s);
6084     }
6085   enough:
6086     if (SvCUR(stuff)) {
6087         PL_expect = XTERM;
6088         if (needargs) {
6089             PL_lex_state = LEX_NORMAL;
6090             PL_nextval[PL_nexttoke].ival = 0;
6091             force_next(',');
6092         }
6093         else
6094             PL_lex_state = LEX_FORMLINE;
6095         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6096         force_next(THING);
6097         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6098         force_next(LSTOP);
6099     }
6100     else {
6101         SvREFCNT_dec(stuff);
6102         PL_lex_formbrack = 0;
6103         PL_bufptr = s;
6104     }
6105     return s;
6106 }
6107
6108 STATIC void
6109 set_csh(void)
6110 {
6111 #ifdef CSH
6112     if (!PL_cshlen)
6113         PL_cshlen = strlen(PL_cshname);
6114 #endif
6115 }
6116
6117 I32
6118 start_subparse(I32 is_format, U32 flags)
6119 {
6120     dTHR;
6121     I32 oldsavestack_ix = PL_savestack_ix;
6122     CV* outsidecv = PL_compcv;
6123     AV* comppadlist;
6124
6125     if (PL_compcv) {
6126         assert(SvTYPE(PL_compcv) == SVt_PVCV);
6127     }
6128     save_I32(&PL_subline);
6129     save_item(PL_subname);
6130     SAVEI32(PL_padix);
6131     SAVESPTR(PL_curpad);
6132     SAVESPTR(PL_comppad);
6133     SAVESPTR(PL_comppad_name);
6134     SAVESPTR(PL_compcv);
6135     SAVEI32(PL_comppad_name_fill);
6136     SAVEI32(PL_min_intro_pending);
6137     SAVEI32(PL_max_intro_pending);
6138     SAVEI32(PL_pad_reset_pending);
6139
6140     PL_compcv = (CV*)NEWSV(1104,0);
6141     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6142     CvFLAGS(PL_compcv) |= flags;
6143
6144     PL_comppad = newAV();
6145     av_push(PL_comppad, Nullsv);
6146     PL_curpad = AvARRAY(PL_comppad);
6147     PL_comppad_name = newAV();
6148     PL_comppad_name_fill = 0;
6149     PL_min_intro_pending = 0;
6150     PL_padix = 0;
6151     PL_subline = PL_curcop->cop_line;
6152 #ifdef USE_THREADS
6153     av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6154     PL_curpad[0] = (SV*)newAV();
6155     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
6156 #endif /* USE_THREADS */
6157
6158     comppadlist = newAV();
6159     AvREAL_off(comppadlist);
6160     av_store(comppadlist, 0, (SV*)PL_comppad_name);
6161     av_store(comppadlist, 1, (SV*)PL_comppad);
6162
6163     CvPADLIST(PL_compcv) = comppadlist;
6164     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6165 #ifdef USE_THREADS
6166     CvOWNER(PL_compcv) = 0;
6167     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6168     MUTEX_INIT(CvMUTEXP(PL_compcv));
6169 #endif /* USE_THREADS */
6170
6171     return oldsavestack_ix;
6172 }
6173
6174 int
6175 yywarn(char *s)
6176 {
6177     dTHR;
6178     --PL_error_count;
6179     PL_in_eval |= 2;
6180     yyerror(s);
6181     PL_in_eval &= ~2;
6182     return 0;
6183 }
6184
6185 int
6186 yyerror(char *s)
6187 {
6188     dTHR;
6189     char *where = NULL;
6190     char *context = NULL;
6191     int contlen = -1;
6192     SV *msg;
6193
6194     if (!yychar || (yychar == ';' && !PL_rsfp))
6195         where = "at EOF";
6196     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6197       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6198         while (isSPACE(*PL_oldoldbufptr))
6199             PL_oldoldbufptr++;
6200         context = PL_oldoldbufptr;
6201         contlen = PL_bufptr - PL_oldoldbufptr;
6202     }
6203     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6204       PL_oldbufptr != PL_bufptr) {
6205         while (isSPACE(*PL_oldbufptr))
6206             PL_oldbufptr++;
6207         context = PL_oldbufptr;
6208         contlen = PL_bufptr - PL_oldbufptr;
6209     }
6210     else if (yychar > 255)
6211         where = "next token ???";
6212     else if ((yychar & 127) == 127) {
6213         if (PL_lex_state == LEX_NORMAL ||
6214            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6215             where = "at end of line";
6216         else if (PL_lex_inpat)
6217             where = "within pattern";
6218         else
6219             where = "within string";
6220     }
6221     else {
6222         SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6223         if (yychar < 32)
6224             sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6225         else if (isPRINT_LC(yychar))
6226             sv_catpvf(where_sv, "%c", yychar);
6227         else
6228             sv_catpvf(where_sv, "\\%03o", yychar & 255);
6229         where = SvPVX(where_sv);
6230     }
6231     msg = sv_2mortal(newSVpv(s, 0));
6232     sv_catpvf(msg, " at %_ line %ld, ",
6233               GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6234     if (context)
6235         sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6236     else
6237         sv_catpvf(msg, "%s\n", where);
6238     if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6239         sv_catpvf(msg,
6240         "  (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6241                 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6242         PL_multi_end = 0;
6243     }
6244     if (PL_in_eval & 2)
6245         warn("%_", msg);
6246     else if (PL_in_eval)
6247         sv_catsv(ERRSV, msg);
6248     else
6249         PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6250     if (++PL_error_count >= 10)
6251         croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6252     PL_in_my = 0;
6253     PL_in_my_stash = Nullhv;
6254     return 0;
6255 }
6256
6257