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