toke.c

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