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