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