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