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