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