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 #  undef yylex
  85 #  define yylex()       Perl_yylex(aTHX_ yylval_pointer, yychar_pointer)
  86 #endif
  87
  88 #include "keywords.h"
  89
  90 #ifdef CLINE
  91 #undef CLINE
  92 #endif
  93 #define CLINE (PL_copline = (PL_curcop->cop_line < PL_copline ? PL_curcop->cop_line : PL_copline))
  94
  95 #define TOKEN(retval) return (PL_bufptr = s,(int)retval)
  96 #define OPERATOR(retval) return (PL_expect = XTERM,PL_bufptr = s,(int)retval)
  97 #define AOPERATOR(retval) return ao((PL_expect = XTERM,PL_bufptr = s,(int)retval))
  98 #define PREBLOCK(retval) return (PL_expect = XBLOCK,PL_bufptr = s,(int)retval)
  99 #define PRETERMBLOCK(retval) return (PL_expect = XTERMBLOCK,PL_bufptr = s,(int)retval)
 100 #define PREREF(retval) return (PL_expect = XREF,PL_bufptr = s,(int)retval)
 101 #define TERM(retval) return (CLINE, PL_expect = XOPERATOR,PL_bufptr = s,(int)retval)
 102 #define LOOPX(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LOOPEX)
 103 #define FTST(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)UNIOP)
 104 #define FUN0(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC0)
 105 #define FUN1(f) return(yylval.ival = f,PL_expect = XOPERATOR,PL_bufptr = s,(int)FUNC1)
 106 #define BOop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITOROP))
 107 #define BAop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)BITANDOP))
 108 #define SHop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)SHIFTOP))
 109 #define PWop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)POWOP))
 110 #define PMop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MATCHOP)
 111 #define Aop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)ADDOP))
 112 #define Mop(f) return ao((yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)MULOP))
 113 #define Eop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)EQOP)
 114 #define Rop(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)RELOP)
 115
 116 /* This bit of chicanery makes a unary function followed by
 117  * a parenthesis into a function with one argument, highest precedence.
 118  */
 119 #define UNI(f) return(yylval.ival = f, \
 120         PL_expect = XTERM, \
 121         PL_bufptr = s, \
 122         PL_last_uni = PL_oldbufptr, \
 123         PL_last_lop_op = f, \
 124         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 125
 126 #define UNIBRACK(f) return(yylval.ival = f, \
 127         PL_bufptr = s, \
 128         PL_last_uni = PL_oldbufptr, \
 129         (*s == '(' || (s = skipspace(s), *s == '(') ? (int)FUNC1 : (int)UNIOP) )
 130
 131 /* grandfather return to old style */
 132 #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP)
 133
 134 STATIC int
 135 S_ao(pTHX_ int toketype)
 136 {
 137     if (*PL_bufptr == '=') {
 138         PL_bufptr++;
 139         if (toketype == ANDAND)
 140             yylval.ival = OP_ANDASSIGN;
 141         else if (toketype == OROR)
 142             yylval.ival = OP_ORASSIGN;
 143         toketype = ASSIGNOP;
 144     }
 145     return toketype;
 146 }
 147
 148 STATIC void
 149 S_no_op(pTHX_ char *what, char *s)
 150 {
 151     char *oldbp = PL_bufptr;
 152     bool is_first = (PL_oldbufptr == PL_linestart);
 153
 154     PL_bufptr = s;
 155     yywarn(Perl_form(aTHX_ "%s found where operator expected", what));
 156     if (is_first)
 157         Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n");
 158     else if (PL_oldoldbufptr && isIDFIRST_lazy(PL_oldoldbufptr)) {
 159         char *t;
 160         for (t = PL_oldoldbufptr; *t && (isALNUM_lazy(t) || *t == ':'); t++) ;
 161         if (t < PL_bufptr && isSPACE(*t))
 162             Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n",
 163                 t - PL_oldoldbufptr, PL_oldoldbufptr);
 164
 165     }
 166     else if (s <= oldbp)
 167         Perl_warn(aTHX_ "\t(Missing operator before end of line?)\n");
 168     else
 169         Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
 170     PL_bufptr = oldbp;
 171 }
 172
 173 STATIC void
 174 S_missingterm(pTHX_ char *s)
 175 {
 176     char tmpbuf[3];
 177     char q;
 178     if (s) {
 179         char *nl = strrchr(s,'\n');
 180         if (nl)
 181             *nl = '\0';
 182     }
 183     else if (
 184 #ifdef EBCDIC
 185         iscntrl(PL_multi_close)
 186 #else
 187         PL_multi_close < 32 || PL_multi_close == 127
 188 #endif
 189         ) {
 190         *tmpbuf = '^';
 191         tmpbuf[1] = toCTRL(PL_multi_close);
 192         s = "\\n";
 193         tmpbuf[2] = '\0';
 194         s = tmpbuf;
 195     }
 196     else {
 197         *tmpbuf = PL_multi_close;
 198         tmpbuf[1] = '\0';
 199         s = tmpbuf;
 200     }
 201     q = strchr(s,'"') ? '\'' : '"';
 202     Perl_croak(aTHX_ "Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 203 }
 204
 205 void
 206 Perl_deprecate(pTHX_ char *s)
 207 {
 208     dTHR;
 209     if (ckWARN(WARN_DEPRECATED))
 210         Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s);
 211 }
 212
 213 STATIC void
 214 S_depcom(pTHX)
 215 {
 216     deprecate("comma-less variable list");
 217 }
 218
 219 #ifdef WIN32
 220
 221 STATIC I32
 222 S_win32_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 223 {
 224  I32 count = FILTER_READ(idx+1, sv, maxlen);
 225  if (count > 0 && !maxlen)
 226   win32_strip_return(sv);
 227  return count;
 228 }
 229 #endif
 230
 231 STATIC I32
 232 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 233 {
 234     I32 count = FILTER_READ(idx+1, sv, maxlen);
 235     if (count) {
 236         U8* tmps;
 237         U8* tend;
 238         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
 239         tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
 240         sv_usepvn(sv, (char*)tmps, tend - tmps);
 241
 242     }
 243     return count;
 244 }
 245
 246 STATIC I32
 247 S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 248 {
 249     I32 count = FILTER_READ(idx+1, sv, maxlen);
 250     if (count) {
 251         U8* tmps;
 252         U8* tend;
 253         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
 254         tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
 255         sv_usepvn(sv, (char*)tmps, tend - tmps);
 256
 257     }
 258     return count;
 259 }
 260
 261 void
 262 Perl_lex_start(pTHX_ SV *line)
 263 {
 264     dTHR;
 265     char *s;
 266     STRLEN len;
 267
 268     SAVEI32(PL_lex_dojoin);
 269     SAVEI32(PL_lex_brackets);
 270     SAVEI32(PL_lex_fakebrack);
 271     SAVEI32(PL_lex_casemods);
 272     SAVEI32(PL_lex_starts);
 273     SAVEI32(PL_lex_state);
 274     SAVESPTR(PL_lex_inpat);
 275     SAVEI32(PL_lex_inwhat);
 276     SAVEI16(PL_curcop->cop_line);
 277     SAVEPPTR(PL_bufptr);
 278     SAVEPPTR(PL_bufend);
 279     SAVEPPTR(PL_oldbufptr);
 280     SAVEPPTR(PL_oldoldbufptr);
 281     SAVEPPTR(PL_linestart);
 282     SAVESPTR(PL_linestr);
 283     SAVEPPTR(PL_lex_brackstack);
 284     SAVEPPTR(PL_lex_casestack);
 285     SAVEDESTRUCTOR(S_restore_rsfp, PL_rsfp);
 286     SAVESPTR(PL_lex_stuff);
 287     SAVEI32(PL_lex_defer);
 288     SAVESPTR(PL_lex_repl);
 289     SAVEDESTRUCTOR(S_restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
 290     SAVEDESTRUCTOR(S_restore_lex_expect, PL_tokenbuf + PL_expect);
 291
 292     PL_lex_state = LEX_NORMAL;
 293     PL_lex_defer = 0;
 294     PL_expect = XSTATE;
 295     PL_lex_brackets = 0;
 296     PL_lex_fakebrack = 0;
 297     New(899, PL_lex_brackstack, 120, char);
 298     New(899, PL_lex_casestack, 12, char);
 299     SAVEFREEPV(PL_lex_brackstack);
 300     SAVEFREEPV(PL_lex_casestack);
 301     PL_lex_casemods = 0;
 302     *PL_lex_casestack = '\0';
 303     PL_lex_dojoin = 0;
 304     PL_lex_starts = 0;
 305     PL_lex_stuff = Nullsv;
 306     PL_lex_repl = Nullsv;
 307     PL_lex_inpat = 0;
 308     PL_lex_inwhat = 0;
 309     PL_linestr = line;
 310     if (SvREADONLY(PL_linestr))
 311         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 312     s = SvPV(PL_linestr, len);
 313     if (len && s[len-1] != ';') {
 314         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
 315             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 316         sv_catpvn(PL_linestr, "\n;", 2);
 317     }
 318     SvTEMP_off(PL_linestr);
 319     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
 320     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
 321     SvREFCNT_dec(PL_rs);
 322     PL_rs = newSVpvn("\n", 1);
 323     PL_rsfp = 0;
 324 }
 325
 326 void
 327 Perl_lex_end(pTHX)
 328 {
 329     PL_doextract = FALSE;
 330 }
 331
 332 STATIC void
 333 S_restore_rsfp(pTHX_ void *f)
 334 {
 335     PerlIO *fp = (PerlIO*)f;
 336
 337     if (PL_rsfp == PerlIO_stdin())
 338         PerlIO_clearerr(PL_rsfp);
 339     else if (PL_rsfp && (PL_rsfp != fp))
 340         PerlIO_close(PL_rsfp);
 341     PL_rsfp = fp;
 342 }
 343
 344 STATIC void
 345 S_restore_expect(pTHX_ void *e)
 346 {
 347     /* a safe way to store a small integer in a pointer */
 348     PL_expect = (expectation)((char *)e - PL_tokenbuf);
 349 }
 350
 351 STATIC void
 352 S_restore_lex_expect(pTHX_ void *e)
 353 {
 354     /* a safe way to store a small integer in a pointer */
 355     PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
 356 }
 357
 358 STATIC void
 359 S_incline(pTHX_ char *s)
 360 {
 361     dTHR;
 362     char *t;
 363     char *n;
 364     char ch;
 365     int sawline = 0;
 366
 367     PL_curcop->cop_line++;
 368     if (*s++ != '#')
 369         return;
 370     while (*s == ' ' || *s == '\t') s++;
 371     if (strnEQ(s, "line ", 5)) {
 372         s += 5;
 373         sawline = 1;
 374     }
 375     if (!isDIGIT(*s))
 376         return;
 377     n = s;
 378     while (isDIGIT(*s))
 379         s++;
 380     while (*s == ' ' || *s == '\t')
 381         s++;
 382     if (*s == '"' && (t = strchr(s+1, '"')))
 383         s++;
 384     else {
 385         if (!sawline)
 386             return;             /* false alarm */
 387         for (t = s; !isSPACE(*t); t++) ;
 388     }
 389     ch = *t;
 390     *t = '\0';
 391     if (t - s > 0)
 392         PL_curcop->cop_filegv = gv_fetchfile(s);
 393     else
 394         PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
 395     *t = ch;
 396     PL_curcop->cop_line = atoi(n)-1;
 397 }
 398
 399 STATIC char *
 400 S_skipspace(pTHX_ register char *s)
 401 {
 402     dTHR;
 403     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 404         while (s < PL_bufend && (*s == ' ' || *s == '\t'))
 405             s++;
 406         return s;
 407     }
 408     for (;;) {
 409         STRLEN prevlen;
 410         while (s < PL_bufend && isSPACE(*s)) {
 411             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
 412                 incline(s);
 413         }
 414         if (s < PL_bufend && *s == '#') {
 415             while (s < PL_bufend && *s != '\n')
 416                 s++;
 417             if (s < PL_bufend) {
 418                 s++;
 419                 if (PL_in_eval && !PL_rsfp) {
 420                     incline(s);
 421                     continue;
 422                 }
 423             }
 424         }
 425         if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
 426             return s;
 427         if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
 428             if (PL_minus_n || PL_minus_p) {
 429                 sv_setpv(PL_linestr,PL_minus_p ?
 430                          ";}continue{print or die qq(-p destination: $!\\n)" :
 431                          "");
 432                 sv_catpv(PL_linestr,";}");
 433                 PL_minus_n = PL_minus_p = 0;
 434             }
 435             else
 436                 sv_setpv(PL_linestr,";");
 437             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
 438             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
 439             if (PL_preprocess && !PL_in_eval)
 440                 (void)PerlProc_pclose(PL_rsfp);
 441             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
 442                 PerlIO_clearerr(PL_rsfp);
 443             else
 444                 (void)PerlIO_close(PL_rsfp);
 445             PL_rsfp = Nullfp;
 446             return s;
 447         }
 448         PL_linestart = PL_bufptr = s + prevlen;
 449         PL_bufend = s + SvCUR(PL_linestr);
 450         s = PL_bufptr;
 451         incline(s);
 452         if (PERLDB_LINE && PL_curstash != PL_debstash) {
 453             SV *sv = NEWSV(85,0);
 454
 455             sv_upgrade(sv, SVt_PVMG);
 456             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
 457             av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
 458         }
 459     }
 460 }
 461
 462 STATIC void
 463 S_check_uni(pTHX)
 464 {
 465     char *s;
 466     char ch;
 467     char *t;
 468
 469     if (PL_oldoldbufptr != PL_last_uni)
 470         return;
 471     while (isSPACE(*PL_last_uni))
 472         PL_last_uni++;
 473     for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
 474     if ((t = strchr(s, '(')) && t < PL_bufptr)
 475         return;
 476     ch = *s;
 477     *s = '\0';
 478     Perl_warn(aTHX_ "Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
 479     *s = ch;
 480 }
 481
 482 #ifdef CRIPPLED_CC
 483
 484 #undef UNI
 485 #define UNI(f) return uni(f,s)
 486
 487 STATIC int
 488 S_uni(pTHX_ I32 f, char *s)
 489 {
 490     yylval.ival = f;
 491     PL_expect = XTERM;
 492     PL_bufptr = s;
 493     PL_last_uni = PL_oldbufptr;
 494     PL_last_lop_op = f;
 495     if (*s == '(')
 496         return FUNC1;
 497     s = skipspace(s);
 498     if (*s == '(')
 499         return FUNC1;
 500     else
 501         return UNIOP;
 502 }
 503
 504 #endif /* CRIPPLED_CC */
 505
 506 #define LOP(f,x) return lop(f,x,s)
 507
 508 STATIC I32
 509 S_lop(pTHX_ I32 f, expectation x, char *s)
 510 {
 511     dTHR;
 512     yylval.ival = f;
 513     CLINE;
 514     PL_expect = x;
 515     PL_bufptr = s;
 516     PL_last_lop = PL_oldbufptr;
 517     PL_last_lop_op = f;
 518     if (PL_nexttoke)
 519         return LSTOP;
 520     if (*s == '(')
 521         return FUNC;
 522     s = skipspace(s);
 523     if (*s == '(')
 524         return FUNC;
 525     else
 526         return LSTOP;
 527 }
 528
 529 STATIC void
 530 S_force_next(pTHX_ I32 type)
 531 {
 532     PL_nexttype[PL_nexttoke] = type;
 533     PL_nexttoke++;
 534     if (PL_lex_state != LEX_KNOWNEXT) {
 535         PL_lex_defer = PL_lex_state;
 536         PL_lex_expect = PL_expect;
 537         PL_lex_state = LEX_KNOWNEXT;
 538     }
 539 }
 540
 541 STATIC char *
 542 S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
 543 {
 544     register char *s;
 545     STRLEN len;
 546
 547     start = skipspace(start);
 548     s = start;
 549     if (isIDFIRST_lazy(s) ||
 550         (allow_pack && *s == ':') ||
 551         (allow_initial_tick && *s == '\'') )
 552     {
 553         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
 554         if (check_keyword && keyword(PL_tokenbuf, len))
 555             return start;
 556         if (token == METHOD) {
 557             s = skipspace(s);
 558             if (*s == '(')
 559                 PL_expect = XTERM;
 560             else {
 561                 PL_expect = XOPERATOR;
 562             }
 563         }
 564         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
 565         PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
 566         force_next(token);
 567     }
 568     return s;
 569 }
 570
 571 STATIC void
 572 S_force_ident(pTHX_ register char *s, int kind)
 573 {
 574     if (s && *s) {
 575         OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
 576         PL_nextval[PL_nexttoke].opval = o;
 577         force_next(WORD);
 578         if (kind) {
 579             dTHR;               /* just for in_eval */
 580             o->op_private = OPpCONST_ENTERED;
 581             /* XXX see note in pp_entereval() for why we forgo typo
 582                warnings if the symbol must be introduced in an eval.
 583                GSAR 96-10-12 */
 584             gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
 585                 kind == '$' ? SVt_PV :
 586                 kind == '@' ? SVt_PVAV :
 587                 kind == '%' ? SVt_PVHV :
 588                               SVt_PVGV
 589                 );
 590         }
 591     }
 592 }
 593
 594 STATIC char *
 595 S_force_version(pTHX_ char *s)
 596 {
 597     OP *version = Nullop;
 598
 599     s = skipspace(s);
 600
 601     /* default VERSION number -- GBARR */
 602
 603     if(isDIGIT(*s)) {
 604         char *d;
 605         int c;
 606         for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
 607         if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
 608             s = scan_num(s);
 609             /* real VERSION number -- GBARR */
 610             version = yylval.opval;
 611         }
 612     }
 613
 614     /* NOTE: The parser sees the package name and the VERSION swapped */
 615     PL_nextval[PL_nexttoke].opval = version;
 616     force_next(WORD);
 617
 618     return (s);
 619 }
 620
 621 STATIC SV *
 622 S_tokeq(pTHX_ SV *sv)
 623 {
 624     register char *s;
 625     register char *send;
 626     register char *d;
 627     STRLEN len = 0;
 628     SV *pv = sv;
 629
 630     if (!SvLEN(sv))
 631         goto finish;
 632
 633     s = SvPV_force(sv, len);
 634     if (SvIVX(sv) == -1)
 635         goto finish;
 636     send = s + len;
 637     while (s < send && *s != '\\')
 638         s++;
 639     if (s == send)
 640         goto finish;
 641     d = s;
 642     if ( PL_hints & HINT_NEW_STRING )
 643         pv = sv_2mortal(newSVpvn(SvPVX(pv), len));
 644     while (s < send) {
 645         if (*s == '\\') {
 646             if (s + 1 < send && (s[1] == '\\'))
 647                 s++;            /* all that, just for this */
 648         }
 649         *d++ = *s++;
 650     }
 651     *d = '\0';
 652     SvCUR_set(sv, d - SvPVX(sv));
 653   finish:
 654     if ( PL_hints & HINT_NEW_STRING )
 655        return new_constant(NULL, 0, "q", sv, pv, "q");
 656     return sv;
 657 }
 658
 659 STATIC I32
 660 S_sublex_start(pTHX)
 661 {
 662     register I32 op_type = yylval.ival;
 663
 664     if (op_type == OP_NULL) {
 665         yylval.opval = PL_lex_op;
 666         PL_lex_op = Nullop;
 667         return THING;
 668     }
 669     if (op_type == OP_CONST || op_type == OP_READLINE) {
 670         SV *sv = tokeq(PL_lex_stuff);
 671
 672         if (SvTYPE(sv) == SVt_PVIV) {
 673             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
 674             STRLEN len;
 675             char *p;
 676             SV *nsv;
 677
 678             p = SvPV(sv, len);
 679             nsv = newSVpvn(p, len);
 680             SvREFCNT_dec(sv);
 681             sv = nsv;
 682         }
 683         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
 684         PL_lex_stuff = Nullsv;
 685         return THING;
 686     }
 687
 688     PL_sublex_info.super_state = PL_lex_state;
 689     PL_sublex_info.sub_inwhat = op_type;
 690     PL_sublex_info.sub_op = PL_lex_op;
 691     PL_lex_state = LEX_INTERPPUSH;
 692
 693     PL_expect = XTERM;
 694     if (PL_lex_op) {
 695         yylval.opval = PL_lex_op;
 696         PL_lex_op = Nullop;
 697         return PMFUNC;
 698     }
 699     else
 700         return FUNC;
 701 }
 702
 703 STATIC I32
 704 S_sublex_push(pTHX)
 705 {
 706     dTHR;
 707     ENTER;
 708
 709     PL_lex_state = PL_sublex_info.super_state;
 710     SAVEI32(PL_lex_dojoin);
 711     SAVEI32(PL_lex_brackets);
 712     SAVEI32(PL_lex_fakebrack);
 713     SAVEI32(PL_lex_casemods);
 714     SAVEI32(PL_lex_starts);
 715     SAVEI32(PL_lex_state);
 716     SAVESPTR(PL_lex_inpat);
 717     SAVEI32(PL_lex_inwhat);
 718     SAVEI16(PL_curcop->cop_line);
 719     SAVEPPTR(PL_bufptr);
 720     SAVEPPTR(PL_oldbufptr);
 721     SAVEPPTR(PL_oldoldbufptr);
 722     SAVEPPTR(PL_linestart);
 723     SAVESPTR(PL_linestr);
 724     SAVEPPTR(PL_lex_brackstack);
 725     SAVEPPTR(PL_lex_casestack);
 726
 727     PL_linestr = PL_lex_stuff;
 728     PL_lex_stuff = Nullsv;
 729
 730     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
 731     PL_bufend += SvCUR(PL_linestr);
 732     SAVEFREESV(PL_linestr);
 733
 734     PL_lex_dojoin = FALSE;
 735     PL_lex_brackets = 0;
 736     PL_lex_fakebrack = 0;
 737     New(899, PL_lex_brackstack, 120, char);
 738     New(899, PL_lex_casestack, 12, char);
 739     SAVEFREEPV(PL_lex_brackstack);
 740     SAVEFREEPV(PL_lex_casestack);
 741     PL_lex_casemods = 0;
 742     *PL_lex_casestack = '\0';
 743     PL_lex_starts = 0;
 744     PL_lex_state = LEX_INTERPCONCAT;
 745     PL_curcop->cop_line = PL_multi_start;
 746
 747     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
 748     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
 749         PL_lex_inpat = PL_sublex_info.sub_op;
 750     else
 751         PL_lex_inpat = Nullop;
 752
 753     return '(';
 754 }
 755
 756 STATIC I32
 757 S_sublex_done(pTHX)
 758 {
 759     if (!PL_lex_starts++) {
 760         PL_expect = XOPERATOR;
 761         yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpvn("",0));
 762         return THING;
 763     }
 764
 765     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
 766         PL_lex_state = LEX_INTERPCASEMOD;
 767         return yylex();
 768     }
 769
 770     /* Is there a right-hand side to take care of? */
 771     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
 772         PL_linestr = PL_lex_repl;
 773         PL_lex_inpat = 0;
 774         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
 775         PL_bufend += SvCUR(PL_linestr);
 776         SAVEFREESV(PL_linestr);
 777         PL_lex_dojoin = FALSE;
 778         PL_lex_brackets = 0;
 779         PL_lex_fakebrack = 0;
 780         PL_lex_casemods = 0;
 781         *PL_lex_casestack = '\0';
 782         PL_lex_starts = 0;
 783         if (SvEVALED(PL_lex_repl)) {
 784             PL_lex_state = LEX_INTERPNORMAL;
 785             PL_lex_starts++;
 786             /*  we don't clear PL_lex_repl here, so that we can check later
 787                 whether this is an evalled subst; that means we rely on the
 788                 logic to ensure sublex_done() is called again only via the
 789                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
 790         }
 791         else {
 792             PL_lex_state = LEX_INTERPCONCAT;
 793             PL_lex_repl = Nullsv;
 794         }
 795         return ',';
 796     }
 797     else {
 798         LEAVE;
 799         PL_bufend = SvPVX(PL_linestr);
 800         PL_bufend += SvCUR(PL_linestr);
 801         PL_expect = XOPERATOR;
 802         return ')';
 803     }
 804 }
 805
 806 /*
 807   scan_const
 808
 809   Extracts a pattern, double-quoted string, or transliteration.  This
 810   is terrifying code.
 811
 812   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
 813   processing a pattern (PL_lex_inpat is true), a transliteration
 814   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
 815
 816   Returns a pointer to the character scanned up to. Iff this is
 817   advanced from the start pointer supplied (ie if anything was
 818   successfully parsed), will leave an OP for the substring scanned
 819   in yylval. Caller must intuit reason for not parsing further
 820   by looking at the next characters herself.
 821
 822   In patterns:
 823     backslashes:
 824       double-quoted style: \r and \n
 825       regexp special ones: \D \s
 826       constants: \x3
 827       backrefs: \1 (deprecated in substitution replacements)
 828       case and quoting: \U \Q \E
 829     stops on @ and $, but not for $ as tail anchor
 830
 831   In transliterations:
 832     characters are VERY literal, except for - not at the start or end
 833     of the string, which indicates a range.  scan_const expands the
 834     range to the full set of intermediate characters.
 835
 836   In double-quoted strings:
 837     backslashes:
 838       double-quoted style: \r and \n
 839       constants: \x3
 840       backrefs: \1 (deprecated)
 841       case and quoting: \U \Q \E
 842     stops on @ and $
 843
 844   scan_const does *not* construct ops to handle interpolated strings.
 845   It stops processing as soon as it finds an embedded $ or @ variable
 846   and leaves it to the caller to work out what's going on.
 847
 848   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
 849
 850   $ in pattern could be $foo or could be tail anchor.  Assumption:
 851   it's a tail anchor if $ is the last thing in the string, or if it's
 852   followed by one of ")| \n\t"
 853
 854   \1 (backreferences) are turned into $1
 855
 856   The structure of the code is
 857       while (there's a character to process) {
 858           handle transliteration ranges
 859           skip regexp comments
 860           skip # initiated comments in //x patterns
 861           check for embedded @foo
 862           check for embedded scalars
 863           if (backslash) {
 864               leave intact backslashes from leave (below)
 865               deprecate \1 in strings and sub replacements
 866               handle string-changing backslashes \l \U \Q \E, etc.
 867               switch (what was escaped) {
 868                   handle - in a transliteration (becomes a literal -)
 869                   handle \132 octal characters
 870                   handle 0x15 hex characters
 871                   handle \cV (control V)
 872                   handle printf backslashes (\f, \r, \n, etc)
 873               } (end switch)
 874           } (end if backslash)
 875     } (end while character to read)
 876
 877 */
 878
 879 STATIC char *
 880 S_scan_const(pTHX_ char *start)
 881 {
 882     register char *send = PL_bufend;            /* end of the constant */
 883     SV *sv = NEWSV(93, send - start);           /* sv for the constant */
 884     register char *s = start;                   /* start of the constant */
 885     register char *d = SvPVX(sv);               /* destination for copies */
 886     bool dorange = FALSE;                       /* are we in a translit range? */
 887     I32 len;                                    /* ? */
 888     I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
 889         ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
 890         : UTF;
 891     I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op)
 892         ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
 893         : UTF;
 894
 895     /* leaveit is the set of acceptably-backslashed characters */
 896     char *leaveit =
 897         PL_lex_inpat
 898             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
 899             : "";
 900
 901     while (s < send || dorange) {
 902         /* get transliterations out of the way (they're most literal) */
 903         if (PL_lex_inwhat == OP_TRANS) {
 904             /* expand a range A-Z to the full set of characters.  AIE! */
 905             if (dorange) {
 906                 I32 i;                          /* current expanded character */
 907                 I32 min;                        /* first character in range */
 908                 I32 max;                        /* last character in range */
 909
 910                 i = d - SvPVX(sv);              /* remember current offset */
 911                 SvGROW(sv, SvLEN(sv) + 256);    /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
 912                 d = SvPVX(sv) + i;              /* restore d after the grow potentially has changed the ptr */
 913                 d -= 2;                         /* eat the first char and the - */
 914
 915                 min = (U8)*d;                   /* first char in range */
 916                 max = (U8)d[1];                 /* last char in range  */
 917
 918 #ifndef ASCIIish
 919                 if ((isLOWER(min) && isLOWER(max)) ||
 920                     (isUPPER(min) && isUPPER(max))) {
 921                     if (isLOWER(min)) {
 922                         for (i = min; i <= max; i++)
 923                             if (isLOWER(i))
 924                                 *d++ = i;
 925                     } else {
 926                         for (i = min; i <= max; i++)
 927                             if (isUPPER(i))
 928                                 *d++ = i;
 929                     }
 930                 }
 931                 else
 932 #endif
 933                     for (i = min; i <= max; i++)
 934                         *d++ = i;
 935
 936                 /* mark the range as done, and continue */
 937                 dorange = FALSE;
 938                 continue;
 939             }
 940
 941             /* range begins (ignore - as first or last char) */
 942             else if (*s == '-' && s+1 < send  && s != start) {
 943                 if (utf) {
 944                     *d++ = (char)0xff;  /* use illegal utf8 byte--see pmtrans */
 945                     s++;
 946                     continue;
 947                 }
 948                 dorange = TRUE;
 949                 s++;
 950             }
 951         }
 952
 953         /* if we get here, we're not doing a transliteration */
 954
 955         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
 956            except for the last char, which will be done separately. */
 957         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
 958             if (s[2] == '#') {
 959                 while (s < send && *s != ')')
 960                     *d++ = *s++;
 961             } else if (s[2] == '{'
 962                        || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
 963                 I32 count = 1;
 964                 char *regparse = s + (s[2] == '{' ? 3 : 4);
 965                 char c;
 966
 967                 while (count && (c = *regparse)) {
 968                     if (c == '\\' && regparse[1])
 969                         regparse++;
 970                     else if (c == '{')
 971                         count++;
 972                     else if (c == '}')
 973                         count--;
 974                     regparse++;
 975                 }
 976                 if (*regparse != ')') {
 977                     regparse--;         /* Leave one char for continuation. */
 978                     yyerror("Sequence (?{...}) not terminated or not {}-balanced");
 979                 }
 980                 while (s < regparse)
 981                     *d++ = *s++;
 982             }
 983         }
 984
 985         /* likewise skip #-initiated comments in //x patterns */
 986         else if (*s == '#' && PL_lex_inpat &&
 987           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
 988             while (s+1 < send && *s != '\n')
 989                 *d++ = *s++;
 990         }
 991
 992         /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
 993         else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
 994             break;
 995
 996         /* check for embedded scalars.  only stop if we're sure it's a
 997            variable.
 998         */
 999         else if (*s == '$') {
1000             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1001                 break;
1002             if (s + 1 < send && !strchr("()| \n\t", s[1]))
1003                 break;          /* in regexp, $ might be tail anchor */
1004         }
1005
1006         /* (now in tr/// code again) */
1007
1008         if (*s & 0x80 && thisutf) {
1009             dTHR;                       /* only for ckWARN */
1010             if (ckWARN(WARN_UTF8)) {
1011                 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1012                 if (len) {
1013                     while (len--)
1014                         *d++ = *s++;
1015                     continue;
1016                 }
1017             }
1018         }
1019
1020         /* backslashes */
1021         if (*s == '\\' && s+1 < send) {
1022             s++;
1023
1024             /* some backslashes we leave behind */
1025             if (*leaveit && *s && strchr(leaveit, *s)) {
1026                 *d++ = '\\';
1027                 *d++ = *s++;
1028                 continue;
1029             }
1030
1031             /* deprecate \1 in strings and substitution replacements */
1032             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1033                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1034             {
1035                 dTHR;                   /* only for ckWARN */
1036                 if (ckWARN(WARN_SYNTAX))
1037                     Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1038                 *--s = '$';
1039                 break;
1040             }
1041
1042             /* string-change backslash escapes */
1043             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1044                 --s;
1045                 break;
1046             }
1047
1048             /* if we get here, it's either a quoted -, or a digit */
1049             switch (*s) {
1050
1051             /* quoted - in transliterations */
1052             case '-':
1053                 if (PL_lex_inwhat == OP_TRANS) {
1054                     *d++ = *s++;
1055                     continue;
1056                 }
1057                 /* FALL THROUGH */
1058             default:
1059                 {
1060                     dTHR;
1061                     if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1062                         Perl_warner(aTHX_ WARN_UNSAFE,
1063                                "Unrecognized escape \\%c passed through",
1064                                *s);
1065                     /* default action is to copy the quoted character */
1066                     *d++ = *s++;
1067                     continue;
1068                 }
1069
1070             /* \132 indicates an octal constant */
1071             case '0': case '1': case '2': case '3':
1072             case '4': case '5': case '6': case '7':
1073                 *d++ = scan_oct(s, 3, &len);
1074                 s += len;
1075                 continue;
1076
1077             /* \x24 indicates a hex constant */
1078             case 'x':
1079                 ++s;
1080                 if (*s == '{') {
1081                     char* e = strchr(s, '}');
1082
1083                     if (!e) {
1084                         yyerror("Missing right brace on \\x{}");
1085                         e = s;
1086                     }
1087                     if (!utf) {
1088                         dTHR;
1089                         if (ckWARN(WARN_UTF8))
1090                             Perl_warner(aTHX_ WARN_UTF8,
1091                                    "Use of \\x{} without utf8 declaration");
1092                     }
1093                     /* note: utf always shorter than hex */
1094                     d = (char*)uv_to_utf8((U8*)d,
1095                                           scan_hex(s + 1, e - s - 1, &len));
1096                     s = e + 1;
1097
1098                 }
1099                 else {
1100                     UV uv = (UV)scan_hex(s, 2, &len);
1101                     if (utf && PL_lex_inwhat == OP_TRANS &&
1102                         utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1103                     {
1104                         d = (char*)uv_to_utf8((U8*)d, uv);      /* doing a CU or UC */
1105                     }
1106                     else {
1107                         if (uv >= 127 && UTF) {
1108                             dTHR;
1109                             if (ckWARN(WARN_UTF8))
1110                                 Perl_warner(aTHX_ WARN_UTF8,
1111                                     "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1112                                     len,s,len,s);
1113                         }
1114                         *d++ = (char)uv;
1115                     }
1116                     s += len;
1117                 }
1118                 continue;
1119
1120             /* \c is a control character */
1121             case 'c':
1122                 s++;
1123 #ifdef EBCDIC
1124                 *d = *s++;
1125                 if (isLOWER(*d))
1126                    *d = toUPPER(*d);
1127                 *d++ = toCTRL(*d);
1128 #else
1129                 len = *s++;
1130                 *d++ = toCTRL(len);
1131 #endif
1132                 continue;
1133
1134             /* printf-style backslashes, formfeeds, newlines, etc */
1135             case 'b':
1136                 *d++ = '\b';
1137                 break;
1138             case 'n':
1139                 *d++ = '\n';
1140                 break;
1141             case 'r':
1142                 *d++ = '\r';
1143                 break;
1144             case 'f':
1145                 *d++ = '\f';
1146                 break;
1147             case 't':
1148                 *d++ = '\t';
1149                 break;
1150 #ifdef EBCDIC
1151             case 'e':
1152                 *d++ = '\047';  /* CP 1047 */
1153                 break;
1154             case 'a':
1155                 *d++ = '\057';  /* CP 1047 */
1156                 break;
1157 #else
1158             case 'e':
1159                 *d++ = '\033';
1160                 break;
1161             case 'a':
1162                 *d++ = '\007';
1163                 break;
1164 #endif
1165             } /* end switch */
1166
1167             s++;
1168             continue;
1169         } /* end if (backslash) */
1170
1171         *d++ = *s++;
1172     } /* while loop to process each character */
1173
1174     /* terminate the string and set up the sv */
1175     *d = '\0';
1176     SvCUR_set(sv, d - SvPVX(sv));
1177     SvPOK_on(sv);
1178
1179     /* shrink the sv if we allocated more than we used */
1180     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1181         SvLEN_set(sv, SvCUR(sv) + 1);
1182         Renew(SvPVX(sv), SvLEN(sv), char);
1183     }
1184
1185     /* return the substring (via yylval) only if we parsed anything */
1186     if (s > PL_bufptr) {
1187         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1188             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1189                               sv, Nullsv,
1190                               ( PL_lex_inwhat == OP_TRANS
1191                                 ? "tr"
1192                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1193                                     ? "s"
1194                                     : "qq")));
1195         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1196     } else
1197         SvREFCNT_dec(sv);
1198     return s;
1199 }
1200
1201 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1202 STATIC int
1203 S_intuit_more(pTHX_ register char *s)
1204 {
1205     if (PL_lex_brackets)
1206         return TRUE;
1207     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1208         return TRUE;
1209     if (*s != '{' && *s != '[')
1210         return FALSE;
1211     if (!PL_lex_inpat)
1212         return TRUE;
1213
1214     /* In a pattern, so maybe we have {n,m}. */
1215     if (*s == '{') {
1216         s++;
1217         if (!isDIGIT(*s))
1218             return TRUE;
1219         while (isDIGIT(*s))
1220             s++;
1221         if (*s == ',')
1222             s++;
1223         while (isDIGIT(*s))
1224             s++;
1225         if (*s == '}')
1226             return FALSE;
1227         return TRUE;
1228
1229     }
1230
1231     /* On the other hand, maybe we have a character class */
1232
1233     s++;
1234     if (*s == ']' || *s == '^')
1235         return FALSE;
1236     else {
1237         int weight = 2;         /* let's weigh the evidence */
1238         char seen[256];
1239         unsigned char un_char = 255, last_un_char;
1240         char *send = strchr(s,']');
1241         char tmpbuf[sizeof PL_tokenbuf * 4];
1242
1243         if (!send)              /* has to be an expression */
1244             return TRUE;
1245
1246         Zero(seen,256,char);
1247         if (*s == '$')
1248             weight -= 3;
1249         else if (isDIGIT(*s)) {
1250             if (s[1] != ']') {
1251                 if (isDIGIT(s[1]) && s[2] == ']')
1252                     weight -= 10;
1253             }
1254             else
1255                 weight -= 100;
1256         }
1257         for (; s < send; s++) {
1258             last_un_char = un_char;
1259             un_char = (unsigned char)*s;
1260             switch (*s) {
1261             case '@':
1262             case '&':
1263             case '$':
1264                 weight -= seen[un_char] * 10;
1265                 if (isALNUM_lazy(s+1)) {
1266                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1267                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1268                         weight -= 100;
1269                     else
1270                         weight -= 10;
1271                 }
1272                 else if (*s == '$' && s[1] &&
1273                   strchr("[#!%*<>()-=",s[1])) {
1274                     if (/*{*/ strchr("])} =",s[2]))
1275                         weight -= 10;
1276                     else
1277                         weight -= 1;
1278                 }
1279                 break;
1280             case '\\':
1281                 un_char = 254;
1282                 if (s[1]) {
1283                     if (strchr("wds]",s[1]))
1284                         weight += 100;
1285                     else if (seen['\''] || seen['"'])
1286                         weight += 1;
1287                     else if (strchr("rnftbxcav",s[1]))
1288                         weight += 40;
1289                     else if (isDIGIT(s[1])) {
1290                         weight += 40;
1291                         while (s[1] && isDIGIT(s[1]))
1292                             s++;
1293                     }
1294                 }
1295                 else
1296                     weight += 100;
1297                 break;
1298             case '-':
1299                 if (s[1] == '\\')
1300                     weight += 50;
1301                 if (strchr("aA01! ",last_un_char))
1302                     weight += 30;
1303                 if (strchr("zZ79~",s[1]))
1304                     weight += 30;
1305                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1306                     weight -= 5;        /* cope with negative subscript */
1307                 break;
1308             default:
1309                 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1310                         isALPHA(*s) && s[1] && isALPHA(s[1])) {
1311                     char *d = tmpbuf;
1312                     while (isALPHA(*s))
1313                         *d++ = *s++;
1314                     *d = '\0';
1315                     if (keyword(tmpbuf, d - tmpbuf))
1316                         weight -= 150;
1317                 }
1318                 if (un_char == last_un_char + 1)
1319                     weight += 5;
1320                 weight -= seen[un_char];
1321                 break;
1322             }
1323             seen[un_char]++;
1324         }
1325         if (weight >= 0)        /* probably a character class */
1326             return FALSE;
1327     }
1328
1329     return TRUE;
1330 }
1331
1332 STATIC int
1333 S_intuit_method(pTHX_ char *start, GV *gv)
1334 {
1335     char *s = start + (*start == '$');
1336     char tmpbuf[sizeof PL_tokenbuf];
1337     STRLEN len;
1338     GV* indirgv;
1339
1340     if (gv) {
1341         CV *cv;
1342         if (GvIO(gv))
1343             return 0;
1344         if ((cv = GvCVu(gv))) {
1345             char *proto = SvPVX(cv);
1346             if (proto) {
1347                 if (*proto == ';')
1348                     proto++;
1349                 if (*proto == '*')
1350                     return 0;
1351             }
1352         } else
1353             gv = 0;
1354     }
1355     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1356     if (*start == '$') {
1357         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1358             return 0;
1359         s = skipspace(s);
1360         PL_bufptr = start;
1361         PL_expect = XREF;
1362         return *s == '(' ? FUNCMETH : METHOD;
1363     }
1364     if (!keyword(tmpbuf, len)) {
1365         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1366             len -= 2;
1367             tmpbuf[len] = '\0';
1368             goto bare_package;
1369         }
1370         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1371         if (indirgv && GvCVu(indirgv))
1372             return 0;
1373         /* filehandle or package name makes it a method */
1374         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1375             s = skipspace(s);
1376             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1377                 return 0;       /* no assumptions -- "=>" quotes bearword */
1378       bare_package:
1379             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1380                                                    newSVpvn(tmpbuf,len));
1381             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1382             PL_expect = XTERM;
1383             force_next(WORD);
1384             PL_bufptr = s;
1385             return *s == '(' ? FUNCMETH : METHOD;
1386         }
1387     }
1388     return 0;
1389 }
1390
1391 STATIC char*
1392 S_incl_perldb(pTHX)
1393 {
1394     if (PL_perldb) {
1395         char *pdb = PerlEnv_getenv("PERL5DB");
1396
1397         if (pdb)
1398             return pdb;
1399         SETERRNO(0,SS$_NORMAL);
1400         return "BEGIN { require 'perl5db.pl' }";
1401     }
1402     return "";
1403 }
1404
1405
1406 /* Encoded script support. filter_add() effectively inserts a
1407  * 'pre-processing' function into the current source input stream.
1408  * Note that the filter function only applies to the current source file
1409  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1410  *
1411  * The datasv parameter (which may be NULL) can be used to pass
1412  * private data to this instance of the filter. The filter function
1413  * can recover the SV using the FILTER_DATA macro and use it to
1414  * store private buffers and state information.
1415  *
1416  * The supplied datasv parameter is upgraded to a PVIO type
1417  * and the IoDIRP field is used to store the function pointer.
1418  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1419  * private use must be set using malloc'd pointers.
1420  */
1421
1422 SV *
1423 Perl_filter_add(pTHX_ filter_t funcp, SV *datasv)
1424 {
1425     if (!funcp){ /* temporary handy debugging hack to be deleted */
1426         PL_filter_debug = atoi((char*)datasv);
1427         return NULL;
1428     }
1429     if (!PL_rsfp_filters)
1430         PL_rsfp_filters = newAV();
1431     if (!datasv)
1432         datasv = NEWSV(255,0);
1433     if (!SvUPGRADE(datasv, SVt_PVIO))
1434         Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO");
1435     IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1436     if (PL_filter_debug) {
1437         STRLEN n_a;
1438         Perl_warn(aTHX_ "filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1439     }
1440     av_unshift(PL_rsfp_filters, 1);
1441     av_store(PL_rsfp_filters, 0, datasv) ;
1442     return(datasv);
1443 }
1444
1445
1446 /* Delete most recently added instance of this filter function. */
1447 void
1448 Perl_filter_del(pTHX_ filter_t funcp)
1449 {
1450     if (PL_filter_debug)
1451         Perl_warn(aTHX_ "filter_del func %p", funcp);
1452     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1453         return;
1454     /* if filter is on top of stack (usual case) just pop it off */
1455     if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1456         IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) = NULL;
1457         sv_free(av_pop(PL_rsfp_filters));
1458
1459         return;
1460     }
1461     /* we need to search for the correct entry and clear it     */
1462     Perl_die(aTHX_ "filter_del can only delete in reverse order (currently)");
1463 }
1464
1465
1466 /* Invoke the n'th filter function for the current rsfp.         */
1467 I32
1468 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen)
1469
1470
1471                         /* 0 = read one text line */
1472 {
1473     filter_t funcp;
1474     SV *datasv = NULL;
1475
1476     if (!PL_rsfp_filters)
1477         return -1;
1478     if (idx > AvFILLp(PL_rsfp_filters)){       /* Any more filters?     */
1479         /* Provide a default input filter to make life easy.    */
1480         /* Note that we append to the line. This is handy.      */
1481         if (PL_filter_debug)
1482             Perl_warn(aTHX_ "filter_read %d: from rsfp\n", idx);
1483         if (maxlen) {
1484             /* Want a block */
1485             int len ;
1486             int old_len = SvCUR(buf_sv) ;
1487
1488             /* ensure buf_sv is large enough */
1489             SvGROW(buf_sv, old_len + maxlen) ;
1490             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1491                 if (PerlIO_error(PL_rsfp))
1492                     return -1;          /* error */
1493                 else
1494                     return 0 ;          /* end of file */
1495             }
1496             SvCUR_set(buf_sv, old_len + len) ;
1497         } else {
1498             /* Want a line */
1499             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1500                 if (PerlIO_error(PL_rsfp))
1501                     return -1;          /* error */
1502                 else
1503                     return 0 ;          /* end of file */
1504             }
1505         }
1506         return SvCUR(buf_sv);
1507     }
1508     /* Skip this filter slot if filter has been deleted */
1509     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1510         if (PL_filter_debug)
1511             Perl_warn(aTHX_ "filter_read %d: skipped (filter deleted)\n", idx);
1512         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1513     }
1514     /* Get function pointer hidden within datasv        */
1515     funcp = (filter_t)IoDIRP(datasv);
1516     if (PL_filter_debug) {
1517         STRLEN n_a;
1518         Perl_warn(aTHX_ "filter_read %d: via function %p (%s)\n",
1519                 idx, funcp, SvPV(datasv,n_a));
1520     }
1521     /* Call function. The function is expected to       */
1522     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
1523     /* Return: <0:error, =0:eof, >0:not eof             */
1524     return (*funcp)(aTHXo_ idx, buf_sv, maxlen);
1525 }
1526
1527 STATIC char *
1528 S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
1529 {
1530 #ifdef WIN32FILTER
1531     if (!PL_rsfp_filters) {
1532         filter_add(win32_textfilter,NULL);
1533     }
1534 #endif
1535     if (PL_rsfp_filters) {
1536
1537         if (!append)
1538             SvCUR_set(sv, 0);   /* start with empty line        */
1539         if (FILTER_READ(0, sv, 0) > 0)
1540             return ( SvPVX(sv) ) ;
1541         else
1542             return Nullch ;
1543     }
1544     else
1545         return (sv_gets(sv, fp, append));
1546 }
1547
1548
1549 #ifdef DEBUGGING
1550     static char* exp_name[] =
1551         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1552 #endif
1553
1554 /*
1555   yylex
1556
1557   Works out what to call the token just pulled out of the input
1558   stream.  The yacc parser takes care of taking the ops we return and
1559   stitching them into a tree.
1560
1561   Returns:
1562     PRIVATEREF
1563
1564   Structure:
1565       if read an identifier
1566           if we're in a my declaration
1567               croak if they tried to say my($foo::bar)
1568               build the ops for a my() declaration
1569           if it's an access to a my() variable
1570               are we in a sort block?
1571                   croak if my($a); $a <=> $b
1572               build ops for access to a my() variable
1573           if in a dq string, and they've said @foo and we can't find @foo
1574               croak
1575           build ops for a bareword
1576       if we already built the token before, use it.
1577 */
1578
1579 int
1580 #ifdef USE_PURE_BISON
1581 Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp)
1582 #else
1583 Perl_yylex(pTHX)
1584 #endif
1585 {
1586     dTHR;
1587     register char *s;
1588     register char *d;
1589     register I32 tmp;
1590     STRLEN len;
1591     GV *gv = Nullgv;
1592     GV **gvp = 0;
1593
1594 #ifdef USE_PURE_BISON
1595     yylval_pointer = lvalp;
1596     yychar_pointer = lcharp;
1597 #endif
1598
1599     /* check if there's an identifier for us to look at */
1600     if (PL_pending_ident) {
1601         /* pit holds the identifier we read and pending_ident is reset */
1602         char pit = PL_pending_ident;
1603         PL_pending_ident = 0;
1604
1605         /* if we're in a my(), we can't allow dynamics here.
1606            $foo'bar has already been turned into $foo::bar, so
1607            just check for colons.
1608
1609            if it's a legal name, the OP is a PADANY.
1610         */
1611         if (PL_in_my) {
1612             if (strchr(PL_tokenbuf,':'))
1613                 yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf));
1614
1615             yylval.opval = newOP(OP_PADANY, 0);
1616             yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1617             return PRIVATEREF;
1618         }
1619
1620         /*
1621            build the ops for accesses to a my() variable.
1622
1623            Deny my($a) or my($b) in a sort block, *if* $a or $b is
1624            then used in a comparison.  This catches most, but not
1625            all cases.  For instance, it catches
1626                sort { my($a); $a <=> $b }
1627            but not
1628                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1629            (although why you'd do that is anyone's guess).
1630         */
1631
1632         if (!strchr(PL_tokenbuf,':')) {
1633 #ifdef USE_THREADS
1634             /* Check for single character per-thread SVs */
1635             if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1636                 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1637                 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1638             {
1639                 yylval.opval = newOP(OP_THREADSV, 0);
1640                 yylval.opval->op_targ = tmp;
1641                 return PRIVATEREF;
1642             }
1643 #endif /* USE_THREADS */
1644             if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1645                 /* if it's a sort block and they're naming $a or $b */
1646                 if (PL_last_lop_op == OP_SORT &&
1647                     PL_tokenbuf[0] == '$' &&
1648                     (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1649                     && !PL_tokenbuf[2])
1650                 {
1651                     for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1652                          d < PL_bufend && *d != '\n';
1653                          d++)
1654                     {
1655                         if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1656                             Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison",
1657                                   PL_tokenbuf);
1658                         }
1659                     }
1660                 }
1661
1662                 yylval.opval = newOP(OP_PADANY, 0);
1663                 yylval.opval->op_targ = tmp;
1664                 return PRIVATEREF;
1665             }
1666         }
1667
1668         /*
1669            Whine if they've said @foo in a doublequoted string,
1670            and @foo isn't a variable we can find in the symbol
1671            table.
1672         */
1673         if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1674             GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1675             if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1676                 yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s",
1677                              PL_tokenbuf, PL_tokenbuf));
1678         }
1679
1680         /* build ops for a bareword */
1681         yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1682         yylval.opval->op_private = OPpCONST_ENTERED;
1683         gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1684                    ((PL_tokenbuf[0] == '$') ? SVt_PV
1685                     : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1686                     : SVt_PVHV));
1687         return WORD;
1688     }
1689
1690     /* no identifier pending identification */
1691
1692     switch (PL_lex_state) {
1693 #ifdef COMMENTARY
1694     case LEX_NORMAL:            /* Some compilers will produce faster */
1695     case LEX_INTERPNORMAL:      /* code if we comment these out. */
1696         break;
1697 #endif
1698
1699     /* when we're already built the next token, just pull it out the queue */
1700     case LEX_KNOWNEXT:
1701         PL_nexttoke--;
1702         yylval = PL_nextval[PL_nexttoke];
1703         if (!PL_nexttoke) {
1704             PL_lex_state = PL_lex_defer;
1705             PL_expect = PL_lex_expect;
1706             PL_lex_defer = LEX_NORMAL;
1707         }
1708         return(PL_nexttype[PL_nexttoke]);
1709
1710     /* interpolated case modifiers like \L \U, including \Q and \E.
1711        when we get here, PL_bufptr is at the \
1712     */
1713     case LEX_INTERPCASEMOD:
1714 #ifdef DEBUGGING
1715         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1716             Perl_croak(aTHX_ "panic: INTERPCASEMOD");
1717 #endif
1718         /* handle \E or end of string */
1719         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1720             char oldmod;
1721
1722             /* if at a \E */
1723             if (PL_lex_casemods) {
1724                 oldmod = PL_lex_casestack[--PL_lex_casemods];
1725                 PL_lex_casestack[PL_lex_casemods] = '\0';
1726
1727                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1728                     PL_bufptr += 2;
1729                     PL_lex_state = LEX_INTERPCONCAT;
1730                 }
1731                 return ')';
1732             }
1733             if (PL_bufptr != PL_bufend)
1734                 PL_bufptr += 2;
1735             PL_lex_state = LEX_INTERPCONCAT;
1736             return yylex();
1737         }
1738         else {
1739             s = PL_bufptr + 1;
1740             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1741                 tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
1742             if (strchr("LU", *s) &&
1743                 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1744             {
1745                 PL_lex_casestack[--PL_lex_casemods] = '\0';
1746                 return ')';
1747             }
1748             if (PL_lex_casemods > 10) {
1749                 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1750                 if (newlb != PL_lex_casestack) {
1751                     SAVEFREEPV(newlb);
1752                     PL_lex_casestack = newlb;
1753                 }
1754             }
1755             PL_lex_casestack[PL_lex_casemods++] = *s;
1756             PL_lex_casestack[PL_lex_casemods] = '\0';
1757             PL_lex_state = LEX_INTERPCONCAT;
1758             PL_nextval[PL_nexttoke].ival = 0;
1759             force_next('(');
1760             if (*s == 'l')
1761                 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1762             else if (*s == 'u')
1763                 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1764             else if (*s == 'L')
1765                 PL_nextval[PL_nexttoke].ival = OP_LC;
1766             else if (*s == 'U')
1767                 PL_nextval[PL_nexttoke].ival = OP_UC;
1768             else if (*s == 'Q')
1769                 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1770             else
1771                 Perl_croak(aTHX_ "panic: yylex");
1772             PL_bufptr = s + 1;
1773             force_next(FUNC);
1774             if (PL_lex_starts) {
1775                 s = PL_bufptr;
1776                 PL_lex_starts = 0;
1777                 Aop(OP_CONCAT);
1778             }
1779             else
1780                 return yylex();
1781         }
1782
1783     case LEX_INTERPPUSH:
1784         return sublex_push();
1785
1786     case LEX_INTERPSTART:
1787         if (PL_bufptr == PL_bufend)
1788             return sublex_done();
1789         PL_expect = XTERM;
1790         PL_lex_dojoin = (*PL_bufptr == '@');
1791         PL_lex_state = LEX_INTERPNORMAL;
1792         if (PL_lex_dojoin) {
1793             PL_nextval[PL_nexttoke].ival = 0;
1794             force_next(',');
1795 #ifdef USE_THREADS
1796             PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1797             PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1798             force_next(PRIVATEREF);
1799 #else
1800             force_ident("\"", '$');
1801 #endif /* USE_THREADS */
1802             PL_nextval[PL_nexttoke].ival = 0;
1803             force_next('$');
1804             PL_nextval[PL_nexttoke].ival = 0;
1805             force_next('(');
1806             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
1807             force_next(FUNC);
1808         }
1809         if (PL_lex_starts++) {
1810             s = PL_bufptr;
1811             Aop(OP_CONCAT);
1812         }
1813         return yylex();
1814
1815     case LEX_INTERPENDMAYBE:
1816         if (intuit_more(PL_bufptr)) {
1817             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
1818             break;
1819         }
1820         /* FALL THROUGH */
1821
1822     case LEX_INTERPEND:
1823         if (PL_lex_dojoin) {
1824             PL_lex_dojoin = FALSE;
1825             PL_lex_state = LEX_INTERPCONCAT;
1826             return ')';
1827         }
1828         if (PL_lex_inwhat == OP_SUBST && PL_linestr == PL_lex_repl
1829             && SvEVALED(PL_lex_repl))
1830         {
1831             if (PL_bufptr != PL_bufend)
1832                 Perl_croak(aTHX_ "Bad evalled substitution pattern");
1833             PL_lex_repl = Nullsv;
1834         }
1835         /* FALLTHROUGH */
1836     case LEX_INTERPCONCAT:
1837 #ifdef DEBUGGING
1838         if (PL_lex_brackets)
1839             Perl_croak(aTHX_ "panic: INTERPCONCAT");
1840 #endif
1841         if (PL_bufptr == PL_bufend)
1842             return sublex_done();
1843
1844         if (SvIVX(PL_linestr) == '\'') {
1845             SV *sv = newSVsv(PL_linestr);
1846             if (!PL_lex_inpat)
1847                 sv = tokeq(sv);
1848             else if ( PL_hints & HINT_NEW_RE )
1849                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1850             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1851             s = PL_bufend;
1852         }
1853         else {
1854             s = scan_const(PL_bufptr);
1855             if (*s == '\\')
1856                 PL_lex_state = LEX_INTERPCASEMOD;
1857             else
1858                 PL_lex_state = LEX_INTERPSTART;
1859         }
1860
1861         if (s != PL_bufptr) {
1862             PL_nextval[PL_nexttoke] = yylval;
1863             PL_expect = XTERM;
1864             force_next(THING);
1865             if (PL_lex_starts++)
1866                 Aop(OP_CONCAT);
1867             else {
1868                 PL_bufptr = s;
1869                 return yylex();
1870             }
1871         }
1872
1873         return yylex();
1874     case LEX_FORMLINE:
1875         PL_lex_state = LEX_NORMAL;
1876         s = scan_formline(PL_bufptr);
1877         if (!PL_lex_formbrack)
1878             goto rightbracket;
1879         OPERATOR(';');
1880     }
1881
1882     s = PL_bufptr;
1883     PL_oldoldbufptr = PL_oldbufptr;
1884     PL_oldbufptr = s;
1885     DEBUG_p( {
1886         PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1887     } )
1888
1889   retry:
1890     switch (*s) {
1891     default:
1892         if (isIDFIRST_lazy(s))
1893             goto keylookup;
1894         Perl_croak(aTHX_ "Unrecognized character \\x%02X", *s & 255);
1895     case 4:
1896     case 26:
1897         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
1898     case 0:
1899         if (!PL_rsfp) {
1900             PL_last_uni = 0;
1901             PL_last_lop = 0;
1902             if (PL_lex_brackets)
1903                 yyerror("Missing right curly or square bracket");
1904             TOKEN(0);
1905         }
1906         if (s++ < PL_bufend)
1907             goto retry;                 /* ignore stray nulls */
1908         PL_last_uni = 0;
1909         PL_last_lop = 0;
1910         if (!PL_in_eval && !PL_preambled) {
1911             PL_preambled = TRUE;
1912             sv_setpv(PL_linestr,incl_perldb());
1913             if (SvCUR(PL_linestr))
1914                 sv_catpv(PL_linestr,";");
1915             if (PL_preambleav){
1916                 while(AvFILLp(PL_preambleav) >= 0) {
1917                     SV *tmpsv = av_shift(PL_preambleav);
1918                     sv_catsv(PL_linestr, tmpsv);
1919                     sv_catpv(PL_linestr, ";");
1920                     sv_free(tmpsv);
1921                 }
1922                 sv_free((SV*)PL_preambleav);
1923                 PL_preambleav = NULL;
1924             }
1925             if (PL_minus_n || PL_minus_p) {
1926                 sv_catpv(PL_linestr, "LINE: while (<>) {");
1927                 if (PL_minus_l)
1928                     sv_catpv(PL_linestr,"chomp;");
1929                 if (PL_minus_a) {
1930                     GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1931                     if (gv)
1932                         GvIMPORTED_AV_on(gv);
1933                     if (PL_minus_F) {
1934                         if (strchr("/'\"", *PL_splitstr)
1935                               && strchr(PL_splitstr + 1, *PL_splitstr))
1936                             Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr);
1937                         else {
1938                             char delim;
1939                             s = "'~#\200\1'"; /* surely one char is unused...*/
1940                             while (s[1] && strchr(PL_splitstr, *s))  s++;
1941                             delim = *s;
1942                             Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c",
1943                                       "q" + (delim == '\''), delim);
1944                             for (s = PL_splitstr; *s; s++) {
1945                                 if (*s == '\\')
1946                                     sv_catpvn(PL_linestr, "\\", 1);
1947                                 sv_catpvn(PL_linestr, s, 1);
1948                             }
1949                             Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim);
1950                         }
1951                     }
1952                     else
1953                         sv_catpv(PL_linestr,"@F=split(' ');");
1954                 }
1955             }
1956             sv_catpv(PL_linestr, "\n");
1957             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1958             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1959             if (PERLDB_LINE && PL_curstash != PL_debstash) {
1960                 SV *sv = NEWSV(85,0);
1961
1962                 sv_upgrade(sv, SVt_PVMG);
1963                 sv_setsv(sv,PL_linestr);
1964                 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1965             }
1966             goto retry;
1967         }
1968         do {
1969             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1970               fake_eof:
1971                 if (PL_rsfp) {
1972                     if (PL_preprocess && !PL_in_eval)
1973                         (void)PerlProc_pclose(PL_rsfp);
1974                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
1975                         PerlIO_clearerr(PL_rsfp);
1976                     else
1977                         (void)PerlIO_close(PL_rsfp);
1978                     PL_rsfp = Nullfp;
1979                     PL_doextract = FALSE;
1980                 }
1981                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
1982                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
1983                     sv_catpv(PL_linestr,";}");
1984                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1985                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1986                     PL_minus_n = PL_minus_p = 0;
1987                     goto retry;
1988                 }
1989                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1990                 sv_setpv(PL_linestr,"");
1991                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
1992             }
1993             if (PL_doextract) {
1994                 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
1995                     PL_doextract = FALSE;
1996
1997                 /* Incest with pod. */
1998                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
1999                     sv_setpv(PL_linestr, "");
2000                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2001                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2002                     PL_doextract = FALSE;
2003                 }
2004             }
2005             incline(s);
2006         } while (PL_doextract);
2007         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2008         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2009             SV *sv = NEWSV(85,0);
2010
2011             sv_upgrade(sv, SVt_PVMG);
2012             sv_setsv(sv,PL_linestr);
2013             av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2014         }
2015         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2016         if (PL_curcop->cop_line == 1) {
2017             while (s < PL_bufend && isSPACE(*s))
2018                 s++;
2019             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2020                 s++;
2021             d = Nullch;
2022             if (!PL_in_eval) {
2023                 if (*s == '#' && *(s+1) == '!')
2024                     d = s + 2;
2025 #ifdef ALTERNATE_SHEBANG
2026                 else {
2027                     static char as[] = ALTERNATE_SHEBANG;
2028                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2029                         d = s + (sizeof(as) - 1);
2030                 }
2031 #endif /* ALTERNATE_SHEBANG */
2032             }
2033             if (d) {
2034                 char *ipath;
2035                 char *ipathend;
2036
2037                 while (isSPACE(*d))
2038                     d++;
2039                 ipath = d;
2040                 while (*d && !isSPACE(*d))
2041                     d++;
2042                 ipathend = d;
2043
2044 #ifdef ARG_ZERO_IS_SCRIPT
2045                 if (ipathend > ipath) {
2046                     /*
2047                      * HP-UX (at least) sets argv[0] to the script name,
2048                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2049                      * at least, set argv[0] to the basename of the Perl
2050                      * interpreter. So, having found "#!", we'll set it right.
2051                      */
2052                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2053                     assert(SvPOK(x) || SvGMAGICAL(x));
2054                     if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2055                         sv_setpvn(x, ipath, ipathend - ipath);
2056                         SvSETMAGIC(x);
2057                     }
2058                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2059                 }
2060 #endif /* ARG_ZERO_IS_SCRIPT */
2061
2062                 /*
2063                  * Look for options.
2064                  */
2065                 d = instr(s,"perl -");
2066                 if (!d)
2067                     d = instr(s,"perl");
2068 #ifdef ALTERNATE_SHEBANG
2069                 /*
2070                  * If the ALTERNATE_SHEBANG on this system starts with a
2071                  * character that can be part of a Perl expression, then if
2072                  * we see it but not "perl", we're probably looking at the
2073                  * start of Perl code, not a request to hand off to some
2074                  * other interpreter.  Similarly, if "perl" is there, but
2075                  * not in the first 'word' of the line, we assume the line
2076                  * contains the start of the Perl program.
2077                  */
2078                 if (d && *s != '#') {
2079                     char *c = ipath;
2080                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2081                         c++;
2082                     if (c < d)
2083                         d = Nullch;     /* "perl" not in first word; ignore */
2084                     else
2085                         *s = '#';       /* Don't try to parse shebang line */
2086                 }
2087 #endif /* ALTERNATE_SHEBANG */
2088                 if (!d &&
2089                     *s == '#' &&
2090                     ipathend > ipath &&
2091                     !PL_minus_c &&
2092                     !instr(s,"indir") &&
2093                     instr(PL_origargv[0],"perl"))
2094                 {
2095                     char **newargv;
2096
2097                     *ipathend = '\0';
2098                     s = ipathend + 1;
2099                     while (s < PL_bufend && isSPACE(*s))
2100                         s++;
2101                     if (s < PL_bufend) {
2102                         Newz(899,newargv,PL_origargc+3,char*);
2103                         newargv[1] = s;
2104                         while (s < PL_bufend && !isSPACE(*s))
2105                             s++;
2106                         *s = '\0';
2107                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2108                     }
2109                     else
2110                         newargv = PL_origargv;
2111                     newargv[0] = ipath;
2112                     PerlProc_execv(ipath, newargv);
2113                     Perl_croak(aTHX_ "Can't exec %s", ipath);
2114                 }
2115                 if (d) {
2116                     U32 oldpdb = PL_perldb;
2117                     bool oldn = PL_minus_n;
2118                     bool oldp = PL_minus_p;
2119
2120                     while (*d && !isSPACE(*d)) d++;
2121                     while (*d == ' ' || *d == '\t') d++;
2122
2123                     if (*d++ == '-') {
2124                         do {
2125                             if (*d == 'M' || *d == 'm') {
2126                                 char *m = d;
2127                                 while (*d && !isSPACE(*d)) d++;
2128                                 Perl_croak(aTHX_ "Too late for \"-%.*s\" option",
2129                                       (int)(d - m), m);
2130                             }
2131                             d = moreswitches(d);
2132                         } while (d);
2133                         if (PERLDB_LINE && !oldpdb ||
2134                             ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2135                               /* if we have already added "LINE: while (<>) {",
2136                                  we must not do it again */
2137                         {
2138                             sv_setpv(PL_linestr, "");
2139                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2140                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2141                             PL_preambled = FALSE;
2142                             if (PERLDB_LINE)
2143                                 (void)gv_fetchfile(PL_origfilename);
2144                             goto retry;
2145                         }
2146                     }
2147                 }
2148             }
2149         }
2150         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2151             PL_bufptr = s;
2152             PL_lex_state = LEX_FORMLINE;
2153             return yylex();
2154         }
2155         goto retry;
2156     case '\r':
2157 #ifdef PERL_STRICT_CR
2158         Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
2159         Perl_croak(aTHX_
2160       "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2161 #endif
2162     case ' ': case '\t': case '\f': case 013:
2163         s++;
2164         goto retry;
2165     case '#':
2166     case '\n':
2167         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2168             d = PL_bufend;
2169             while (s < d && *s != '\n')
2170                 s++;
2171             if (s < d)
2172                 s++;
2173             incline(s);
2174             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2175                 PL_bufptr = s;
2176                 PL_lex_state = LEX_FORMLINE;
2177                 return yylex();
2178             }
2179         }
2180         else {
2181             *s = '\0';
2182             PL_bufend = s;
2183         }
2184         goto retry;
2185     case '-':
2186         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2187             s++;
2188             PL_bufptr = s;
2189             tmp = *s++;
2190
2191             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2192                 s++;
2193
2194             if (strnEQ(s,"=>",2)) {
2195                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2196                 OPERATOR('-');          /* unary minus */
2197             }
2198             PL_last_uni = PL_oldbufptr;
2199             PL_last_lop_op = OP_FTEREAD;        /* good enough */
2200             switch (tmp) {
2201             case 'r': FTST(OP_FTEREAD);
2202             case 'w': FTST(OP_FTEWRITE);
2203             case 'x': FTST(OP_FTEEXEC);
2204             case 'o': FTST(OP_FTEOWNED);
2205             case 'R': FTST(OP_FTRREAD);
2206             case 'W': FTST(OP_FTRWRITE);
2207             case 'X': FTST(OP_FTREXEC);
2208             case 'O': FTST(OP_FTROWNED);
2209             case 'e': FTST(OP_FTIS);
2210             case 'z': FTST(OP_FTZERO);
2211             case 's': FTST(OP_FTSIZE);
2212             case 'f': FTST(OP_FTFILE);
2213             case 'd': FTST(OP_FTDIR);
2214             case 'l': FTST(OP_FTLINK);
2215             case 'p': FTST(OP_FTPIPE);
2216             case 'S': FTST(OP_FTSOCK);
2217             case 'u': FTST(OP_FTSUID);
2218             case 'g': FTST(OP_FTSGID);
2219             case 'k': FTST(OP_FTSVTX);
2220             case 'b': FTST(OP_FTBLK);
2221             case 'c': FTST(OP_FTCHR);
2222             case 't': FTST(OP_FTTTY);
2223             case 'T': FTST(OP_FTTEXT);
2224             case 'B': FTST(OP_FTBINARY);
2225             case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2226             case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2227             case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2228             default:
2229                 Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp);
2230                 break;
2231             }
2232         }
2233         tmp = *s++;
2234         if (*s == tmp) {
2235             s++;
2236             if (PL_expect == XOPERATOR)
2237                 TERM(POSTDEC);
2238             else
2239                 OPERATOR(PREDEC);
2240         }
2241         else if (*s == '>') {
2242             s++;
2243             s = skipspace(s);
2244             if (isIDFIRST_lazy(s)) {
2245                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2246                 TOKEN(ARROW);
2247             }
2248             else if (*s == '$')
2249                 OPERATOR(ARROW);
2250             else
2251                 TERM(ARROW);
2252         }
2253         if (PL_expect == XOPERATOR)
2254             Aop(OP_SUBTRACT);
2255         else {
2256             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2257                 check_uni();
2258             OPERATOR('-');              /* unary minus */
2259         }
2260
2261     case '+':
2262         tmp = *s++;
2263         if (*s == tmp) {
2264             s++;
2265             if (PL_expect == XOPERATOR)
2266                 TERM(POSTINC);
2267             else
2268                 OPERATOR(PREINC);
2269         }
2270         if (PL_expect == XOPERATOR)
2271             Aop(OP_ADD);
2272         else {
2273             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2274                 check_uni();
2275             OPERATOR('+');
2276         }
2277
2278     case '*':
2279         if (PL_expect != XOPERATOR) {
2280             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2281             PL_expect = XOPERATOR;
2282             force_ident(PL_tokenbuf, '*');
2283             if (!*PL_tokenbuf)
2284                 PREREF('*');
2285             TERM('*');
2286         }
2287         s++;
2288         if (*s == '*') {
2289             s++;
2290             PWop(OP_POW);
2291         }
2292         Mop(OP_MULTIPLY);
2293
2294     case '%':
2295         if (PL_expect == XOPERATOR) {
2296             ++s;
2297             Mop(OP_MODULO);
2298         }
2299         PL_tokenbuf[0] = '%';
2300         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2301         if (!PL_tokenbuf[1]) {
2302             if (s == PL_bufend)
2303                 yyerror("Final % should be \\% or %name");
2304             PREREF('%');
2305         }
2306         PL_pending_ident = '%';
2307         TERM('%');
2308
2309     case '^':
2310         s++;
2311         BOop(OP_BIT_XOR);
2312     case '[':
2313         PL_lex_brackets++;
2314         /* FALL THROUGH */
2315     case '~':
2316     case ',':
2317         tmp = *s++;
2318         OPERATOR(tmp);
2319     case ':':
2320         if (s[1] == ':') {
2321             len = 0;
2322             goto just_a_word;
2323         }
2324         s++;
2325         OPERATOR(':');
2326     case '(':
2327         s++;
2328         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2329             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
2330         else
2331             PL_expect = XTERM;
2332         TOKEN('(');
2333     case ';':
2334         if (PL_curcop->cop_line < PL_copline)
2335             PL_copline = PL_curcop->cop_line;
2336         tmp = *s++;
2337         OPERATOR(tmp);
2338     case ')':
2339         tmp = *s++;
2340         s = skipspace(s);
2341         if (*s == '{')
2342             PREBLOCK(tmp);
2343         TERM(tmp);
2344     case ']':
2345         s++;
2346         if (PL_lex_brackets <= 0)
2347             yyerror("Unmatched right square bracket");
2348         else
2349             --PL_lex_brackets;
2350         if (PL_lex_state == LEX_INTERPNORMAL) {
2351             if (PL_lex_brackets == 0) {
2352                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2353                     PL_lex_state = LEX_INTERPEND;
2354             }
2355         }
2356         TERM(']');
2357     case '{':
2358       leftbracket:
2359         s++;
2360         if (PL_lex_brackets > 100) {
2361             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2362             if (newlb != PL_lex_brackstack) {
2363                 SAVEFREEPV(newlb);
2364                 PL_lex_brackstack = newlb;
2365             }
2366         }
2367         switch (PL_expect) {
2368         case XTERM:
2369             if (PL_lex_formbrack) {
2370                 s--;
2371                 PRETERMBLOCK(DO);
2372             }
2373             if (PL_oldoldbufptr == PL_last_lop)
2374                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2375             else
2376                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2377             OPERATOR(HASHBRACK);
2378         case XOPERATOR:
2379             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2380                 s++;
2381             d = s;
2382             PL_tokenbuf[0] = '\0';
2383             if (d < PL_bufend && *d == '-') {
2384                 PL_tokenbuf[0] = '-';
2385                 d++;
2386                 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2387                     d++;
2388             }
2389             if (d < PL_bufend && isIDFIRST_lazy(d)) {
2390                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2391                               FALSE, &len);
2392                 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2393                     d++;
2394                 if (*d == '}') {
2395                     char minus = (PL_tokenbuf[0] == '-');
2396                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2397                     if (minus)
2398                         force_next('-');
2399                 }
2400             }
2401             /* FALL THROUGH */
2402         case XBLOCK:
2403             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2404             PL_expect = XSTATE;
2405             break;
2406         case XTERMBLOCK:
2407             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2408             PL_expect = XSTATE;
2409             break;
2410         default: {
2411                 char *t;
2412                 if (PL_oldoldbufptr == PL_last_lop)
2413                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2414                 else
2415                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2416                 s = skipspace(s);
2417                 if (*s == '}')
2418                     OPERATOR(HASHBRACK);
2419                 /* This hack serves to disambiguate a pair of curlies
2420                  * as being a block or an anon hash.  Normally, expectation
2421                  * determines that, but in cases where we're not in a
2422                  * position to expect anything in particular (like inside
2423                  * eval"") we have to resolve the ambiguity.  This code
2424                  * covers the case where the first term in the curlies is a
2425                  * quoted string.  Most other cases need to be explicitly
2426                  * disambiguated by prepending a `+' before the opening
2427                  * curly in order to force resolution as an anon hash.
2428                  *
2429                  * XXX should probably propagate the outer expectation
2430                  * into eval"" to rely less on this hack, but that could
2431                  * potentially break current behavior of eval"".
2432                  * GSAR 97-07-21
2433                  */
2434                 t = s;
2435                 if (*s == '\'' || *s == '"' || *s == '`') {
2436                     /* common case: get past first string, handling escapes */
2437                     for (t++; t < PL_bufend && *t != *s;)
2438                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
2439                             t++;
2440                     t++;
2441                 }
2442                 else if (*s == 'q') {
2443                     if (++t < PL_bufend
2444                         && (!isALNUM(*t)
2445                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2446                                 && !isALNUM(*t)))) {
2447                         char *tmps;
2448                         char open, close, term;
2449                         I32 brackets = 1;
2450
2451                         while (t < PL_bufend && isSPACE(*t))
2452                             t++;
2453                         term = *t;
2454                         open = term;
2455                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2456                             term = tmps[5];
2457                         close = term;
2458                         if (open == close)
2459                             for (t++; t < PL_bufend; t++) {
2460                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2461                                     t++;
2462                                 else if (*t == open)
2463                                     break;
2464                             }
2465                         else
2466                             for (t++; t < PL_bufend; t++) {
2467                                 if (*t == '\\' && t+1 < PL_bufend)
2468                                     t++;
2469                                 else if (*t == close && --brackets <= 0)
2470                                     break;
2471                                 else if (*t == open)
2472                                     brackets++;
2473                             }
2474                     }
2475                     t++;
2476                 }
2477                 else if (isIDFIRST_lazy(s)) {
2478                     for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2479                 }
2480                 while (t < PL_bufend && isSPACE(*t))
2481                     t++;
2482                 /* if comma follows first term, call it an anon hash */
2483                 /* XXX it could be a comma expression with loop modifiers */
2484                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2485                                    || (*t == '=' && t[1] == '>')))
2486                     OPERATOR(HASHBRACK);
2487                 if (PL_expect == XREF)
2488                     PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2489                 else {
2490                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2491                     PL_expect = XSTATE;
2492                 }
2493             }
2494             break;
2495         }
2496         yylval.ival = PL_curcop->cop_line;
2497         if (isSPACE(*s) || *s == '#')
2498             PL_copline = NOLINE;   /* invalidate current command line number */
2499         TOKEN('{');
2500     case '}':
2501       rightbracket:
2502         s++;
2503         if (PL_lex_brackets <= 0)
2504             yyerror("Unmatched right curly bracket");
2505         else
2506             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2507         if (PL_lex_brackets < PL_lex_formbrack)
2508             PL_lex_formbrack = 0;
2509         if (PL_lex_state == LEX_INTERPNORMAL) {
2510             if (PL_lex_brackets == 0) {
2511                 if (PL_lex_fakebrack) {
2512                     PL_lex_state = LEX_INTERPEND;
2513                     PL_bufptr = s;
2514                     return yylex();     /* ignore fake brackets */
2515                 }
2516                 if (*s == '-' && s[1] == '>')
2517                     PL_lex_state = LEX_INTERPENDMAYBE;
2518                 else if (*s != '[' && *s != '{')
2519                     PL_lex_state = LEX_INTERPEND;
2520             }
2521         }
2522         if (PL_lex_brackets < PL_lex_fakebrack) {
2523             PL_bufptr = s;
2524             PL_lex_fakebrack = 0;
2525             return yylex();             /* ignore fake brackets */
2526         }
2527         force_next('}');
2528         TOKEN(';');
2529     case '&':
2530         s++;
2531         tmp = *s++;
2532         if (tmp == '&')
2533             AOPERATOR(ANDAND);
2534         s--;
2535         if (PL_expect == XOPERATOR) {
2536             if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2537                 PL_curcop->cop_line--;
2538                 Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
2539                 PL_curcop->cop_line++;
2540             }
2541             BAop(OP_BIT_AND);
2542         }
2543
2544         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2545         if (*PL_tokenbuf) {
2546             PL_expect = XOPERATOR;
2547             force_ident(PL_tokenbuf, '&');
2548         }
2549         else
2550             PREREF('&');
2551         yylval.ival = (OPpENTERSUB_AMPER<<8);
2552         TERM('&');
2553
2554     case '|':
2555         s++;
2556         tmp = *s++;
2557         if (tmp == '|')
2558             AOPERATOR(OROR);
2559         s--;
2560         BOop(OP_BIT_OR);
2561     case '=':
2562         s++;
2563         tmp = *s++;
2564         if (tmp == '=')
2565             Eop(OP_EQ);
2566         if (tmp == '>')
2567             OPERATOR(',');
2568         if (tmp == '~')
2569             PMop(OP_MATCH);
2570         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2571             Perl_warner(aTHX_ WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2572         s--;
2573         if (PL_expect == XSTATE && isALPHA(tmp) &&
2574                 (s == PL_linestart+1 || s[-2] == '\n') )
2575         {
2576             if (PL_in_eval && !PL_rsfp) {
2577                 d = PL_bufend;
2578                 while (s < d) {
2579                     if (*s++ == '\n') {
2580                         incline(s);
2581                         if (strnEQ(s,"=cut",4)) {
2582                             s = strchr(s,'\n');
2583                             if (s)
2584                                 s++;
2585                             else
2586                                 s = d;
2587                             incline(s);
2588                             goto retry;
2589                         }
2590                     }
2591                 }
2592                 goto retry;
2593             }
2594             s = PL_bufend;
2595             PL_doextract = TRUE;
2596             goto retry;
2597         }
2598         if (PL_lex_brackets < PL_lex_formbrack) {
2599             char *t;
2600 #ifdef PERL_STRICT_CR
2601             for (t = s; *t == ' ' || *t == '\t'; t++) ;
2602 #else
2603             for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2604 #endif
2605             if (*t == '\n' || *t == '#') {
2606                 s--;
2607                 PL_expect = XBLOCK;
2608                 goto leftbracket;
2609             }
2610         }
2611         yylval.ival = 0;
2612         OPERATOR(ASSIGNOP);
2613     case '!':
2614         s++;
2615         tmp = *s++;
2616         if (tmp == '=')
2617             Eop(OP_NE);
2618         if (tmp == '~')
2619             PMop(OP_NOT);
2620         s--;
2621         OPERATOR('!');
2622     case '<':
2623         if (PL_expect != XOPERATOR) {
2624             if (s[1] != '<' && !strchr(s,'>'))
2625                 check_uni();
2626             if (s[1] == '<')
2627                 s = scan_heredoc(s);
2628             else
2629                 s = scan_inputsymbol(s);
2630             TERM(sublex_start());
2631         }
2632         s++;
2633         tmp = *s++;
2634         if (tmp == '<')
2635             SHop(OP_LEFT_SHIFT);
2636         if (tmp == '=') {
2637             tmp = *s++;
2638             if (tmp == '>')
2639                 Eop(OP_NCMP);
2640             s--;
2641             Rop(OP_LE);
2642         }
2643         s--;
2644         Rop(OP_LT);
2645     case '>':
2646         s++;
2647         tmp = *s++;
2648         if (tmp == '>')
2649             SHop(OP_RIGHT_SHIFT);
2650         if (tmp == '=')
2651             Rop(OP_GE);
2652         s--;
2653         Rop(OP_GT);
2654
2655     case '$':
2656         CLINE;
2657
2658         if (PL_expect == XOPERATOR) {
2659             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2660                 PL_expect = XTERM;
2661                 depcom();
2662                 return ','; /* grandfather non-comma-format format */
2663             }
2664         }
2665
2666         if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2667             if (PL_expect == XOPERATOR)
2668                 no_op("Array length", PL_bufptr);
2669             PL_tokenbuf[0] = '@';
2670             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2671                            FALSE);
2672             if (!PL_tokenbuf[1])
2673                 PREREF(DOLSHARP);
2674             PL_expect = XOPERATOR;
2675             PL_pending_ident = '#';
2676             TOKEN(DOLSHARP);
2677         }
2678
2679         if (PL_expect == XOPERATOR)
2680             no_op("Scalar", PL_bufptr);
2681         PL_tokenbuf[0] = '$';
2682         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2683         if (!PL_tokenbuf[1]) {
2684             if (s == PL_bufend)
2685                 yyerror("Final $ should be \\$ or $name");
2686             PREREF('$');
2687         }
2688
2689         /* This kludge not intended to be bulletproof. */
2690         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2691             yylval.opval = newSVOP(OP_CONST, 0,
2692                                    newSViv((IV)PL_compiling.cop_arybase));
2693             yylval.opval->op_private = OPpCONST_ARYBASE;
2694             TERM(THING);
2695         }
2696
2697         d = s;
2698         tmp = (I32)*s;
2699         if (PL_lex_state == LEX_NORMAL)
2700             s = skipspace(s);
2701
2702         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2703             char *t;
2704             if (*s == '[') {
2705                 PL_tokenbuf[0] = '@';
2706                 if (ckWARN(WARN_SYNTAX)) {
2707                     for(t = s + 1;
2708                         isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2709                         t++) ;
2710                     if (*t++ == ',') {
2711                         PL_bufptr = skipspace(PL_bufptr);
2712                         while (t < PL_bufend && *t != ']')
2713                             t++;
2714                         Perl_warner(aTHX_ WARN_SYNTAX,
2715                                 "Multidimensional syntax %.*s not supported",
2716                                 (t - PL_bufptr) + 1, PL_bufptr);
2717                     }
2718                 }
2719             }
2720             else if (*s == '{') {
2721                 PL_tokenbuf[0] = '%';
2722                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2723                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
2724                 {
2725                     char tmpbuf[sizeof PL_tokenbuf];
2726                     STRLEN len;
2727                     for (t++; isSPACE(*t); t++) ;
2728                     if (isIDFIRST_lazy(t)) {
2729                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2730                         for (; isSPACE(*t); t++) ;
2731                         if (*t == ';' && get_cv(tmpbuf, FALSE))
2732                             Perl_warner(aTHX_ WARN_SYNTAX,
2733                                 "You need to quote \"%s\"", tmpbuf);
2734                     }
2735                 }
2736             }
2737         }
2738
2739         PL_expect = XOPERATOR;
2740         if (PL_lex_state == LEX_NORMAL && isSPACE((char)tmp)) {
2741             bool islop = (PL_last_lop == PL_oldoldbufptr);
2742             if (!islop || PL_last_lop_op == OP_GREPSTART)
2743                 PL_expect = XOPERATOR;
2744             else if (strchr("$@\"'`q", *s))
2745                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
2746             else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2747                 PL_expect = XTERM;              /* e.g. print $fh &sub */
2748             else if (isIDFIRST_lazy(s)) {
2749                 char tmpbuf[sizeof PL_tokenbuf];
2750                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2751                 if (tmp = keyword(tmpbuf, len)) {
2752                     /* binary operators exclude handle interpretations */
2753                     switch (tmp) {
2754                     case -KEY_x:
2755                     case -KEY_eq:
2756                     case -KEY_ne:
2757                     case -KEY_gt:
2758                     case -KEY_lt:
2759                     case -KEY_ge:
2760                     case -KEY_le:
2761                     case -KEY_cmp:
2762                         break;
2763                     default:
2764                         PL_expect = XTERM;      /* e.g. print $fh length() */
2765                         break;
2766                     }
2767                 }
2768                 else {
2769                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2770                     if (gv && GvCVu(gv))
2771                         PL_expect = XTERM;      /* e.g. print $fh subr() */
2772                 }
2773             }
2774             else if (isDIGIT(*s))
2775                 PL_expect = XTERM;              /* e.g. print $fh 3 */
2776             else if (*s == '.' && isDIGIT(s[1]))
2777                 PL_expect = XTERM;              /* e.g. print $fh .3 */
2778             else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2779                 PL_expect = XTERM;              /* e.g. print $fh -1 */
2780             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2781                 PL_expect = XTERM;              /* print $fh <<"EOF" */
2782         }
2783         PL_pending_ident = '$';
2784         TOKEN('$');
2785
2786     case '@':
2787         if (PL_expect == XOPERATOR)
2788             no_op("Array", s);
2789         PL_tokenbuf[0] = '@';
2790         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2791         if (!PL_tokenbuf[1]) {
2792             if (s == PL_bufend)
2793                 yyerror("Final @ should be \\@ or @name");
2794             PREREF('@');
2795         }
2796         if (PL_lex_state == LEX_NORMAL)
2797             s = skipspace(s);
2798         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2799             if (*s == '{')
2800                 PL_tokenbuf[0] = '%';
2801
2802             /* Warn about @ where they meant $. */
2803             if (ckWARN(WARN_SYNTAX)) {
2804                 if (*s == '[' || *s == '{') {
2805                     char *t = s + 1;
2806                     while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2807                         t++;
2808                     if (*t == '}' || *t == ']') {
2809                         t++;
2810                         PL_bufptr = skipspace(PL_bufptr);
2811                         Perl_warner(aTHX_ WARN_SYNTAX,
2812                             "Scalar value %.*s better written as $%.*s",
2813                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2814                     }
2815                 }
2816             }
2817         }
2818         PL_pending_ident = '@';
2819         TERM('@');
2820
2821     case '/':                   /* may either be division or pattern */
2822     case '?':                   /* may either be conditional or pattern */
2823         if (PL_expect != XOPERATOR) {
2824             /* Disable warning on "study /blah/" */
2825             if (PL_oldoldbufptr == PL_last_uni
2826                 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2827                     || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2828                 check_uni();
2829             s = scan_pat(s,OP_MATCH);
2830             TERM(sublex_start());
2831         }
2832         tmp = *s++;
2833         if (tmp == '/')
2834             Mop(OP_DIVIDE);
2835         OPERATOR(tmp);
2836
2837     case '.':
2838         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2839 #ifdef PERL_STRICT_CR
2840             && s[1] == '\n'
2841 #else
2842             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2843 #endif
2844             && (s == PL_linestart || s[-1] == '\n') )
2845         {
2846             PL_lex_formbrack = 0;
2847             PL_expect = XSTATE;
2848             goto rightbracket;
2849         }
2850         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2851             tmp = *s++;
2852             if (*s == tmp) {
2853                 s++;
2854                 if (*s == tmp) {
2855                     s++;
2856                     yylval.ival = OPf_SPECIAL;
2857                 }
2858                 else
2859                     yylval.ival = 0;
2860                 OPERATOR(DOTDOT);
2861             }
2862             if (PL_expect != XOPERATOR)
2863                 check_uni();
2864             Aop(OP_CONCAT);
2865         }
2866         /* FALL THROUGH */
2867     case '0': case '1': case '2': case '3': case '4':
2868     case '5': case '6': case '7': case '8': case '9':
2869         s = scan_num(s);
2870         if (PL_expect == XOPERATOR)
2871             no_op("Number",s);
2872         TERM(THING);
2873
2874     case '\'':
2875         s = scan_str(s);
2876         if (PL_expect == XOPERATOR) {
2877             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2878                 PL_expect = XTERM;
2879                 depcom();
2880                 return ',';     /* grandfather non-comma-format format */
2881             }
2882             else
2883                 no_op("String",s);
2884         }
2885         if (!s)
2886             missingterm((char*)0);
2887         yylval.ival = OP_CONST;
2888         TERM(sublex_start());
2889
2890     case '"':
2891         s = scan_str(s);
2892         if (PL_expect == XOPERATOR) {
2893             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2894                 PL_expect = XTERM;
2895                 depcom();
2896                 return ',';     /* grandfather non-comma-format format */
2897             }
2898             else
2899                 no_op("String",s);
2900         }
2901         if (!s)
2902             missingterm((char*)0);
2903         yylval.ival = OP_CONST;
2904         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2905             if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2906                 yylval.ival = OP_STRINGIFY;
2907                 break;
2908             }
2909         }
2910         TERM(sublex_start());
2911
2912     case '`':
2913         s = scan_str(s);
2914         if (PL_expect == XOPERATOR)
2915             no_op("Backticks",s);
2916         if (!s)
2917             missingterm((char*)0);
2918         yylval.ival = OP_BACKTICK;
2919         set_csh();
2920         TERM(sublex_start());
2921
2922     case '\\':
2923         s++;
2924         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2925             Perl_warner(aTHX_ WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2926                         *s, *s);
2927         if (PL_expect == XOPERATOR)
2928             no_op("Backslash",s);
2929         OPERATOR(REFGEN);
2930
2931     case 'x':
2932         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2933             s++;
2934             Mop(OP_REPEAT);
2935         }
2936         goto keylookup;
2937
2938     case '_':
2939     case 'a': case 'A':
2940     case 'b': case 'B':
2941     case 'c': case 'C':
2942     case 'd': case 'D':
2943     case 'e': case 'E':
2944     case 'f': case 'F':
2945     case 'g': case 'G':
2946     case 'h': case 'H':
2947     case 'i': case 'I':
2948     case 'j': case 'J':
2949     case 'k': case 'K':
2950     case 'l': case 'L':
2951     case 'm': case 'M':
2952     case 'n': case 'N':
2953     case 'o': case 'O':
2954     case 'p': case 'P':
2955     case 'q': case 'Q':
2956     case 'r': case 'R':
2957     case 's': case 'S':
2958     case 't': case 'T':
2959     case 'u': case 'U':
2960     case 'v': case 'V':
2961     case 'w': case 'W':
2962               case 'X':
2963     case 'y': case 'Y':
2964     case 'z': case 'Z':
2965
2966       keylookup: {
2967         STRLEN n_a;
2968         gv = Nullgv;
2969         gvp = 0;
2970
2971         PL_bufptr = s;
2972         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2973
2974         /* Some keywords can be followed by any delimiter, including ':' */
2975         tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
2976                len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
2977                             (PL_tokenbuf[0] == 'q' &&
2978                              strchr("qwxr", PL_tokenbuf[1]))));
2979
2980         /* x::* is just a word, unless x is "CORE" */
2981         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
2982             goto just_a_word;
2983
2984         d = s;
2985         while (d < PL_bufend && isSPACE(*d))
2986                 d++;    /* no comments skipped here, or s### is misparsed */
2987
2988         /* Is this a label? */
2989         if (!tmp && PL_expect == XSTATE
2990               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
2991             s = d + 1;
2992             yylval.pval = savepv(PL_tokenbuf);
2993             CLINE;
2994             TOKEN(LABEL);
2995         }
2996
2997         /* Check for keywords */
2998         tmp = keyword(PL_tokenbuf, len);
2999
3000         /* Is this a word before a => operator? */
3001         if (strnEQ(d,"=>",2)) {
3002             CLINE;
3003             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3004             yylval.opval->op_private = OPpCONST_BARE;
3005             TERM(WORD);
3006         }
3007
3008         if (tmp < 0) {                  /* second-class keyword? */
3009             GV *ogv = Nullgv;   /* override (winner) */
3010             GV *hgv = Nullgv;   /* hidden (loser) */
3011             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3012                 CV *cv;
3013                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3014                     (cv = GvCVu(gv)))
3015                 {
3016                     if (GvIMPORTED_CV(gv))
3017                         ogv = gv;
3018                     else if (! CvMETHOD(cv))
3019                         hgv = gv;
3020                 }
3021                 if (!ogv &&
3022                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3023                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3024                     GvCVu(gv) && GvIMPORTED_CV(gv))
3025                 {
3026                     ogv = gv;
3027                 }
3028             }
3029             if (ogv) {
3030                 tmp = 0;                /* overridden by import or by GLOBAL */
3031             }
3032             else if (gv && !gvp
3033                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3034                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3035             {
3036                 tmp = 0;                /* any sub overrides "weak" keyword */
3037             }
3038             else {                      /* no override */
3039                 tmp = -tmp;
3040                 gv = Nullgv;
3041                 gvp = 0;
3042                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3043                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3044                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
3045                         "Ambiguous call resolved as CORE::%s(), %s",
3046                          GvENAME(hgv), "qualify as such or use &");
3047             }
3048         }
3049
3050       reserved_word:
3051         switch (tmp) {
3052
3053         default:                        /* not a keyword */
3054           just_a_word: {
3055                 SV *sv;
3056                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3057
3058                 /* Get the rest if it looks like a package qualifier */
3059
3060                 if (*s == '\'' || *s == ':' && s[1] == ':') {
3061                     STRLEN morelen;
3062                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3063                                   TRUE, &morelen);
3064                     if (!morelen)
3065                         Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf,
3066                                 *s == '\'' ? "'" : "::");
3067                     len += morelen;
3068                 }
3069
3070                 if (PL_expect == XOPERATOR) {
3071                     if (PL_bufptr == PL_linestart) {
3072                         PL_curcop->cop_line--;
3073                         Perl_warner(aTHX_ WARN_SEMICOLON, PL_warn_nosemi);
3074                         PL_curcop->cop_line++;
3075                     }
3076                     else
3077                         no_op("Bareword",s);
3078                 }
3079
3080                 /* Look for a subroutine with this name in current package,
3081                    unless name is "Foo::", in which case Foo is a bearword
3082                    (and a package name). */
3083
3084                 if (len > 2 &&
3085                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3086                 {
3087                     if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3088                         Perl_warner(aTHX_ WARN_UNSAFE,
3089                             "Bareword \"%s\" refers to nonexistent package",
3090                              PL_tokenbuf);
3091                     len -= 2;
3092                     PL_tokenbuf[len] = '\0';
3093                     gv = Nullgv;
3094                     gvp = 0;
3095                 }
3096                 else {
3097                     len = 0;
3098                     if (!gv)
3099                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3100                 }
3101
3102                 /* if we saw a global override before, get the right name */
3103
3104                 if (gvp) {
3105                     sv = newSVpvn("CORE::GLOBAL::",14);
3106                     sv_catpv(sv,PL_tokenbuf);
3107                 }
3108                 else
3109                     sv = newSVpv(PL_tokenbuf,0);
3110
3111                 /* Presume this is going to be a bareword of some sort. */
3112
3113                 CLINE;
3114                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3115                 yylval.opval->op_private = OPpCONST_BARE;
3116
3117                 /* And if "Foo::", then that's what it certainly is. */
3118
3119                 if (len)
3120                     goto safe_bareword;
3121
3122                 /* See if it's the indirect object for a list operator. */
3123
3124                 if (PL_oldoldbufptr &&
3125                     PL_oldoldbufptr < PL_bufptr &&
3126                     (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3127                     /* NO SKIPSPACE BEFORE HERE! */
3128                     (PL_expect == XREF ||
3129                      ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF))
3130                 {
3131                     bool immediate_paren = *s == '(';
3132
3133                     /* (Now we can afford to cross potential line boundary.) */
3134                     s = skipspace(s);
3135
3136                     /* Two barewords in a row may indicate method call. */
3137
3138                     if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3139                         return tmp;
3140
3141                     /* If not a declared subroutine, it's an indirect object. */
3142                     /* (But it's an indir obj regardless for sort.) */
3143
3144                     if ((PL_last_lop_op == OP_SORT ||
3145                          (!immediate_paren && (!gv || !GvCVu(gv)))) &&
3146                         (PL_last_lop_op != OP_MAPSTART &&
3147                          PL_last_lop_op != OP_GREPSTART))
3148                     {
3149                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3150                         goto bareword;
3151                     }
3152                 }
3153
3154                 /* If followed by a paren, it's certainly a subroutine. */
3155
3156                 PL_expect = XOPERATOR;
3157                 s = skipspace(s);
3158                 if (*s == '(') {
3159                     CLINE;
3160                     if (gv && GvCVu(gv)) {
3161                         for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3162                         if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
3163                             s = d + 1;
3164                             goto its_constant;
3165                         }
3166                     }
3167                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3168                     PL_expect = XOPERATOR;
3169                     force_next(WORD);
3170                     yylval.ival = 0;
3171                     TOKEN('&');
3172                 }
3173
3174                 /* If followed by var or block, call it a method (unless sub) */
3175
3176                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3177                     PL_last_lop = PL_oldbufptr;
3178                     PL_last_lop_op = OP_METHOD;
3179                     PREBLOCK(METHOD);
3180                 }
3181
3182                 /* If followed by a bareword, see if it looks like indir obj. */
3183
3184                 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3185                     return tmp;
3186
3187                 /* Not a method, so call it a subroutine (if defined) */
3188
3189                 if (gv && GvCVu(gv)) {
3190                     CV* cv;
3191                     if (lastchar == '-')
3192                         Perl_warn(aTHX_ "Ambiguous use of -%s resolved as -&%s()",
3193                                 PL_tokenbuf, PL_tokenbuf);
3194                     /* Check for a constant sub */
3195                     cv = GvCV(gv);
3196                     if ((sv = cv_const_sv(cv))) {
3197                   its_constant:
3198                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3199                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3200                         yylval.opval->op_private = 0;
3201                         TOKEN(WORD);
3202                     }
3203
3204                     /* Resolve to GV now. */
3205                     op_free(yylval.opval);
3206                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3207                     yylval.opval->op_private |= OPpENTERSUB_NOPAREN;
3208                     PL_last_lop = PL_oldbufptr;
3209                     PL_last_lop_op = OP_ENTERSUB;
3210                     /* Is there a prototype? */
3211                     if (SvPOK(cv)) {
3212                         STRLEN len;
3213                         char *proto = SvPV((SV*)cv, len);
3214                         if (!len)
3215                             TERM(FUNC0SUB);
3216                         if (strEQ(proto, "$"))
3217                             OPERATOR(UNIOPSUB);
3218                         if (*proto == '&' && *s == '{') {
3219                             sv_setpv(PL_subname,"__ANON__");
3220                             PREBLOCK(LSTOPSUB);
3221                         }
3222                     }
3223                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3224                     PL_expect = XTERM;
3225                     force_next(WORD);
3226                     TOKEN(NOAMP);
3227                 }
3228
3229                 /* Call it a bare word */
3230
3231                 if (PL_hints & HINT_STRICT_SUBS)
3232                     yylval.opval->op_private |= OPpCONST_STRICT;
3233                 else {
3234                 bareword:
3235                     if (ckWARN(WARN_RESERVED)) {
3236                         if (lastchar != '-') {
3237                             for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3238                             if (!*d)
3239                                 Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved,
3240                                        PL_tokenbuf);
3241                         }
3242                     }
3243                 }
3244
3245             safe_bareword:
3246                 if (lastchar && strchr("*%&", lastchar)) {
3247                     Perl_warn(aTHX_ "Operator or semicolon missing before %c%s",
3248                         lastchar, PL_tokenbuf);
3249                     Perl_warn(aTHX_ "Ambiguous use of %c resolved as operator %c",
3250                         lastchar, lastchar);
3251                 }
3252                 TOKEN(WORD);
3253             }
3254
3255         case KEY___FILE__:
3256             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3257                                         newSVsv(GvSV(PL_curcop->cop_filegv)));
3258             TERM(THING);
3259
3260         case KEY___LINE__:
3261             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3262                                     Perl_newSVpvf(aTHX_ "%ld", (long)PL_curcop->cop_line));
3263             TERM(THING);
3264
3265         case KEY___PACKAGE__:
3266             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3267                                         (PL_curstash
3268                                          ? newSVsv(PL_curstname)
3269                                          : &PL_sv_undef));
3270             TERM(THING);
3271
3272         case KEY___DATA__:
3273         case KEY___END__: {
3274             GV *gv;
3275
3276             /*SUPPRESS 560*/
3277             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3278                 char *pname = "main";
3279                 if (PL_tokenbuf[2] == 'D')
3280                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3281                 gv = gv_fetchpv(Perl_form(aTHX_ "%s::DATA", pname), TRUE, SVt_PVIO);
3282                 GvMULTI_on(gv);
3283                 if (!GvIO(gv))
3284                     GvIOp(gv) = newIO();
3285                 IoIFP(GvIOp(gv)) = PL_rsfp;
3286 #if defined(HAS_FCNTL) && defined(F_SETFD)
3287                 {
3288                     int fd = PerlIO_fileno(PL_rsfp);
3289                     fcntl(fd,F_SETFD,fd >= 3);
3290                 }
3291 #endif
3292                 /* Mark this internal pseudo-handle as clean */
3293                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3294                 if (PL_preprocess)
3295                     IoTYPE(GvIOp(gv)) = '|';
3296                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3297                     IoTYPE(GvIOp(gv)) = '-';
3298                 else
3299                     IoTYPE(GvIOp(gv)) = '<';
3300                 PL_rsfp = Nullfp;
3301             }
3302             goto fake_eof;
3303         }
3304
3305         case KEY_AUTOLOAD:
3306         case KEY_DESTROY:
3307         case KEY_BEGIN:
3308         case KEY_END:
3309         case KEY_INIT:
3310             if (PL_expect == XSTATE) {
3311                 s = PL_bufptr;
3312                 goto really_sub;
3313             }
3314             goto just_a_word;
3315
3316         case KEY_CORE:
3317             if (*s == ':' && s[1] == ':') {
3318                 s += 2;
3319                 d = s;
3320                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3321                 tmp = keyword(PL_tokenbuf, len);
3322                 if (tmp < 0)
3323                     tmp = -tmp;
3324                 goto reserved_word;
3325             }
3326             goto just_a_word;
3327
3328         case KEY_abs:
3329             UNI(OP_ABS);
3330
3331         case KEY_alarm:
3332             UNI(OP_ALARM);
3333
3334         case KEY_accept:
3335             LOP(OP_ACCEPT,XTERM);
3336
3337         case KEY_and:
3338             OPERATOR(ANDOP);
3339
3340         case KEY_atan2:
3341             LOP(OP_ATAN2,XTERM);
3342
3343         case KEY_bind:
3344             LOP(OP_BIND,XTERM);
3345
3346         case KEY_binmode:
3347             UNI(OP_BINMODE);
3348
3349         case KEY_bless:
3350             LOP(OP_BLESS,XTERM);
3351
3352         case KEY_chop:
3353             UNI(OP_CHOP);
3354
3355         case KEY_continue:
3356             PREBLOCK(CONTINUE);
3357
3358         case KEY_chdir:
3359             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
3360             UNI(OP_CHDIR);
3361
3362         case KEY_close:
3363             UNI(OP_CLOSE);
3364
3365         case KEY_closedir:
3366             UNI(OP_CLOSEDIR);
3367
3368         case KEY_cmp:
3369             Eop(OP_SCMP);
3370
3371         case KEY_caller:
3372             UNI(OP_CALLER);
3373
3374         case KEY_crypt:
3375 #ifdef FCRYPT
3376             if (!PL_cryptseen++)
3377                 init_des();
3378 #endif
3379             LOP(OP_CRYPT,XTERM);
3380
3381         case KEY_chmod:
3382             if (ckWARN(WARN_OCTAL)) {
3383                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3384                 if (*d != '0' && isDIGIT(*d))
3385                     yywarn("chmod: mode argument is missing initial 0");
3386             }
3387             LOP(OP_CHMOD,XTERM);
3388
3389         case KEY_chown:
3390             LOP(OP_CHOWN,XTERM);
3391
3392         case KEY_connect:
3393             LOP(OP_CONNECT,XTERM);
3394
3395         case KEY_chr:
3396             UNI(OP_CHR);
3397
3398         case KEY_cos:
3399             UNI(OP_COS);
3400
3401         case KEY_chroot:
3402             UNI(OP_CHROOT);
3403
3404         case KEY_do:
3405             s = skipspace(s);
3406             if (*s == '{')
3407                 PRETERMBLOCK(DO);
3408             if (*s != '\'')
3409                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3410             OPERATOR(DO);
3411
3412         case KEY_die:
3413             PL_hints |= HINT_BLOCK_SCOPE;
3414             LOP(OP_DIE,XTERM);
3415
3416         case KEY_defined:
3417             UNI(OP_DEFINED);
3418
3419         case KEY_delete:
3420             UNI(OP_DELETE);
3421
3422         case KEY_dbmopen:
3423             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3424             LOP(OP_DBMOPEN,XTERM);
3425
3426         case KEY_dbmclose:
3427             UNI(OP_DBMCLOSE);
3428
3429         case KEY_dump:
3430             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3431             LOOPX(OP_DUMP);
3432
3433         case KEY_else:
3434             PREBLOCK(ELSE);
3435
3436         case KEY_elsif:
3437             yylval.ival = PL_curcop->cop_line;
3438             OPERATOR(ELSIF);
3439
3440         case KEY_eq:
3441             Eop(OP_SEQ);
3442
3443         case KEY_exists:
3444             UNI(OP_EXISTS);
3445
3446         case KEY_exit:
3447             UNI(OP_EXIT);
3448
3449         case KEY_eval:
3450             s = skipspace(s);
3451             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3452             UNIBRACK(OP_ENTEREVAL);
3453
3454         case KEY_eof:
3455             UNI(OP_EOF);
3456
3457         case KEY_exp:
3458             UNI(OP_EXP);
3459
3460         case KEY_each:
3461             UNI(OP_EACH);
3462
3463         case KEY_exec:
3464             set_csh();
3465             LOP(OP_EXEC,XREF);
3466
3467         case KEY_endhostent:
3468             FUN0(OP_EHOSTENT);
3469
3470         case KEY_endnetent:
3471             FUN0(OP_ENETENT);
3472
3473         case KEY_endservent:
3474             FUN0(OP_ESERVENT);
3475
3476         case KEY_endprotoent:
3477             FUN0(OP_EPROTOENT);
3478
3479         case KEY_endpwent:
3480             FUN0(OP_EPWENT);
3481
3482         case KEY_endgrent:
3483             FUN0(OP_EGRENT);
3484
3485         case KEY_for:
3486         case KEY_foreach:
3487             yylval.ival = PL_curcop->cop_line;
3488             s = skipspace(s);
3489             if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3490                 char *p = s;
3491                 if ((PL_bufend - p) >= 3 &&
3492                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3493                     p += 2;
3494                 p = skipspace(p);
3495                 if (isIDFIRST_lazy(p))
3496                     Perl_croak(aTHX_ "Missing $ on loop variable");
3497             }
3498             OPERATOR(FOR);
3499
3500         case KEY_formline:
3501             LOP(OP_FORMLINE,XTERM);
3502
3503         case KEY_fork:
3504             FUN0(OP_FORK);
3505
3506         case KEY_fcntl:
3507             LOP(OP_FCNTL,XTERM);
3508
3509         case KEY_fileno:
3510             UNI(OP_FILENO);
3511
3512         case KEY_flock:
3513             LOP(OP_FLOCK,XTERM);
3514
3515         case KEY_gt:
3516             Rop(OP_SGT);
3517
3518         case KEY_ge:
3519             Rop(OP_SGE);
3520
3521         case KEY_grep:
3522             LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3523
3524         case KEY_goto:
3525             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3526             LOOPX(OP_GOTO);
3527
3528         case KEY_gmtime:
3529             UNI(OP_GMTIME);
3530
3531         case KEY_getc:
3532             UNI(OP_GETC);
3533
3534         case KEY_getppid:
3535             FUN0(OP_GETPPID);
3536
3537         case KEY_getpgrp:
3538             UNI(OP_GETPGRP);
3539
3540         case KEY_getpriority:
3541             LOP(OP_GETPRIORITY,XTERM);
3542
3543         case KEY_getprotobyname:
3544             UNI(OP_GPBYNAME);
3545
3546         case KEY_getprotobynumber:
3547             LOP(OP_GPBYNUMBER,XTERM);
3548
3549         case KEY_getprotoent:
3550             FUN0(OP_GPROTOENT);
3551
3552         case KEY_getpwent:
3553             FUN0(OP_GPWENT);
3554
3555         case KEY_getpwnam:
3556             UNI(OP_GPWNAM);
3557
3558         case KEY_getpwuid:
3559             UNI(OP_GPWUID);
3560
3561         case KEY_getpeername:
3562             UNI(OP_GETPEERNAME);
3563
3564         case KEY_gethostbyname:
3565             UNI(OP_GHBYNAME);
3566
3567         case KEY_gethostbyaddr:
3568             LOP(OP_GHBYADDR,XTERM);
3569
3570         case KEY_gethostent:
3571             FUN0(OP_GHOSTENT);
3572
3573         case KEY_getnetbyname:
3574             UNI(OP_GNBYNAME);
3575
3576         case KEY_getnetbyaddr:
3577             LOP(OP_GNBYADDR,XTERM);
3578
3579         case KEY_getnetent:
3580             FUN0(OP_GNETENT);
3581
3582         case KEY_getservbyname:
3583             LOP(OP_GSBYNAME,XTERM);
3584
3585         case KEY_getservbyport:
3586             LOP(OP_GSBYPORT,XTERM);
3587
3588         case KEY_getservent:
3589             FUN0(OP_GSERVENT);
3590
3591         case KEY_getsockname:
3592             UNI(OP_GETSOCKNAME);
3593
3594         case KEY_getsockopt:
3595             LOP(OP_GSOCKOPT,XTERM);
3596
3597         case KEY_getgrent:
3598             FUN0(OP_GGRENT);
3599
3600         case KEY_getgrnam:
3601             UNI(OP_GGRNAM);
3602
3603         case KEY_getgrgid:
3604             UNI(OP_GGRGID);
3605
3606         case KEY_getlogin:
3607             FUN0(OP_GETLOGIN);
3608
3609         case KEY_glob:
3610             set_csh();
3611             LOP(OP_GLOB,XTERM);
3612
3613         case KEY_hex:
3614             UNI(OP_HEX);
3615
3616         case KEY_if:
3617             yylval.ival = PL_curcop->cop_line;
3618             OPERATOR(IF);
3619
3620         case KEY_index:
3621             LOP(OP_INDEX,XTERM);
3622
3623         case KEY_int:
3624             UNI(OP_INT);
3625
3626         case KEY_ioctl:
3627             LOP(OP_IOCTL,XTERM);
3628
3629         case KEY_join:
3630             LOP(OP_JOIN,XTERM);
3631
3632         case KEY_keys:
3633             UNI(OP_KEYS);
3634
3635         case KEY_kill:
3636             LOP(OP_KILL,XTERM);
3637
3638         case KEY_last:
3639             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3640             LOOPX(OP_LAST);
3641
3642         case KEY_lc:
3643             UNI(OP_LC);
3644
3645         case KEY_lcfirst:
3646             UNI(OP_LCFIRST);
3647
3648         case KEY_local:
3649             OPERATOR(LOCAL);
3650
3651         case KEY_length:
3652             UNI(OP_LENGTH);
3653
3654         case KEY_lt:
3655             Rop(OP_SLT);
3656
3657         case KEY_le:
3658             Rop(OP_SLE);
3659
3660         case KEY_localtime:
3661             UNI(OP_LOCALTIME);
3662
3663         case KEY_log:
3664             UNI(OP_LOG);
3665
3666         case KEY_link:
3667             LOP(OP_LINK,XTERM);
3668
3669         case KEY_listen:
3670             LOP(OP_LISTEN,XTERM);
3671
3672         case KEY_lock:
3673             UNI(OP_LOCK);
3674
3675         case KEY_lstat:
3676             UNI(OP_LSTAT);
3677
3678         case KEY_m:
3679             s = scan_pat(s,OP_MATCH);
3680             TERM(sublex_start());
3681
3682         case KEY_map:
3683             LOP(OP_MAPSTART, XREF);
3684
3685         case KEY_mkdir:
3686             LOP(OP_MKDIR,XTERM);
3687
3688         case KEY_msgctl:
3689             LOP(OP_MSGCTL,XTERM);
3690
3691         case KEY_msgget:
3692             LOP(OP_MSGGET,XTERM);
3693
3694         case KEY_msgrcv:
3695             LOP(OP_MSGRCV,XTERM);
3696
3697         case KEY_msgsnd:
3698             LOP(OP_MSGSND,XTERM);
3699
3700         case KEY_my:
3701             PL_in_my = TRUE;
3702             s = skipspace(s);
3703             if (isIDFIRST_lazy(s)) {
3704                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3705                 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3706                 if (!PL_in_my_stash) {
3707                     char tmpbuf[1024];
3708                     PL_bufptr = s;
3709                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3710                     yyerror(tmpbuf);
3711                 }
3712             }
3713             OPERATOR(MY);
3714
3715         case KEY_next:
3716             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3717             LOOPX(OP_NEXT);
3718
3719         case KEY_ne:
3720             Eop(OP_SNE);
3721
3722         case KEY_no:
3723             if (PL_expect != XSTATE)
3724                 yyerror("\"no\" not allowed in expression");
3725             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3726             s = force_version(s);
3727             yylval.ival = 0;
3728             OPERATOR(USE);
3729
3730         case KEY_not:
3731             OPERATOR(NOTOP);
3732
3733         case KEY_open:
3734             s = skipspace(s);
3735             if (isIDFIRST_lazy(s)) {
3736                 char *t;
3737                 for (d = s; isALNUM_lazy(d); d++) ;
3738                 t = skipspace(d);
3739                 if (strchr("|&*+-=!?:.", *t))
3740                     Perl_warn(aTHX_ "Precedence problem: open %.*s should be open(%.*s)",
3741                         d-s,s, d-s,s);
3742             }
3743             LOP(OP_OPEN,XTERM);
3744
3745         case KEY_or:
3746             yylval.ival = OP_OR;
3747             OPERATOR(OROP);
3748
3749         case KEY_ord:
3750             UNI(OP_ORD);
3751
3752         case KEY_oct:
3753             UNI(OP_OCT);
3754
3755         case KEY_opendir:
3756             LOP(OP_OPEN_DIR,XTERM);
3757
3758         case KEY_print:
3759             checkcomma(s,PL_tokenbuf,"filehandle");
3760             LOP(OP_PRINT,XREF);
3761
3762         case KEY_printf:
3763             checkcomma(s,PL_tokenbuf,"filehandle");
3764             LOP(OP_PRTF,XREF);
3765
3766         case KEY_prototype:
3767             UNI(OP_PROTOTYPE);
3768
3769         case KEY_push:
3770             LOP(OP_PUSH,XTERM);
3771
3772         case KEY_pop:
3773             UNI(OP_POP);
3774
3775         case KEY_pos:
3776             UNI(OP_POS);
3777
3778         case KEY_pack:
3779             LOP(OP_PACK,XTERM);
3780
3781         case KEY_package:
3782             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3783             OPERATOR(PACKAGE);
3784
3785         case KEY_pipe:
3786             LOP(OP_PIPE_OP,XTERM);
3787
3788         case KEY_q:
3789             s = scan_str(s);
3790             if (!s)
3791                 missingterm((char*)0);
3792             yylval.ival = OP_CONST;
3793             TERM(sublex_start());
3794
3795         case KEY_quotemeta:
3796             UNI(OP_QUOTEMETA);
3797
3798         case KEY_qw:
3799             s = scan_str(s);
3800             if (!s)
3801                 missingterm((char*)0);
3802             force_next(')');
3803             if (SvCUR(PL_lex_stuff)) {
3804                 OP *words = Nullop;
3805                 int warned = 0;
3806                 d = SvPV_force(PL_lex_stuff, len);
3807                 while (len) {
3808                     for (; isSPACE(*d) && len; --len, ++d) ;
3809                     if (len) {
3810                         char *b = d;
3811                         if (!warned && ckWARN(WARN_SYNTAX)) {
3812                             for (; !isSPACE(*d) && len; --len, ++d) {
3813                                 if (*d == ',') {
3814                                     Perl_warner(aTHX_ WARN_SYNTAX,
3815                                         "Possible attempt to separate words with commas");
3816                                     ++warned;
3817                                 }
3818                                 else if (*d == '#') {
3819                                     Perl_warner(aTHX_ WARN_SYNTAX,
3820                                         "Possible attempt to put comments in qw() list");
3821                                     ++warned;
3822                                 }
3823                             }
3824                         }
3825                         else {
3826                             for (; !isSPACE(*d) && len; --len, ++d) ;
3827                         }
3828                         words = append_elem(OP_LIST, words,
3829                                             newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
3830                     }
3831                 }
3832                 if (words) {
3833                     PL_nextval[PL_nexttoke].opval = words;
3834                     force_next(THING);
3835                 }
3836             }
3837             if (PL_lex_stuff)
3838                 SvREFCNT_dec(PL_lex_stuff);
3839             PL_lex_stuff = Nullsv;
3840             PL_expect = XTERM;
3841             TOKEN('(');
3842
3843         case KEY_qq:
3844             s = scan_str(s);
3845             if (!s)
3846                 missingterm((char*)0);
3847             yylval.ival = OP_STRINGIFY;
3848             if (SvIVX(PL_lex_stuff) == '\'')
3849                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
3850             TERM(sublex_start());
3851
3852         case KEY_qr:
3853             s = scan_pat(s,OP_QR);
3854             TERM(sublex_start());
3855
3856         case KEY_qx:
3857             s = scan_str(s);
3858             if (!s)
3859                 missingterm((char*)0);
3860             yylval.ival = OP_BACKTICK;
3861             set_csh();
3862             TERM(sublex_start());
3863
3864         case KEY_return:
3865             OLDLOP(OP_RETURN);
3866
3867         case KEY_require:
3868             *PL_tokenbuf = '\0';
3869             s = force_word(s,WORD,TRUE,TRUE,FALSE);
3870             if (isIDFIRST_lazy(PL_tokenbuf))
3871                 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3872             else if (*s == '<')
3873                 yyerror("<> should be quotes");
3874             UNI(OP_REQUIRE);
3875
3876         case KEY_reset:
3877             UNI(OP_RESET);
3878
3879         case KEY_redo:
3880             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3881             LOOPX(OP_REDO);
3882
3883         case KEY_rename:
3884             LOP(OP_RENAME,XTERM);
3885
3886         case KEY_rand:
3887             UNI(OP_RAND);
3888
3889         case KEY_rmdir:
3890             UNI(OP_RMDIR);
3891
3892         case KEY_rindex:
3893             LOP(OP_RINDEX,XTERM);
3894
3895         case KEY_read:
3896             LOP(OP_READ,XTERM);
3897
3898         case KEY_readdir:
3899             UNI(OP_READDIR);
3900
3901         case KEY_readline:
3902             set_csh();
3903             UNI(OP_READLINE);
3904
3905         case KEY_readpipe:
3906             set_csh();
3907             UNI(OP_BACKTICK);
3908
3909         case KEY_rewinddir:
3910             UNI(OP_REWINDDIR);
3911
3912         case KEY_recv:
3913             LOP(OP_RECV,XTERM);
3914
3915         case KEY_reverse:
3916             LOP(OP_REVERSE,XTERM);
3917
3918         case KEY_readlink:
3919             UNI(OP_READLINK);
3920
3921         case KEY_ref:
3922             UNI(OP_REF);
3923
3924         case KEY_s:
3925             s = scan_subst(s);
3926             if (yylval.opval)
3927                 TERM(sublex_start());
3928             else
3929                 TOKEN(1);       /* force error */
3930
3931         case KEY_chomp:
3932             UNI(OP_CHOMP);
3933
3934         case KEY_scalar:
3935             UNI(OP_SCALAR);
3936
3937         case KEY_select:
3938             LOP(OP_SELECT,XTERM);
3939
3940         case KEY_seek:
3941             LOP(OP_SEEK,XTERM);
3942
3943         case KEY_semctl:
3944             LOP(OP_SEMCTL,XTERM);
3945
3946         case KEY_semget:
3947             LOP(OP_SEMGET,XTERM);
3948
3949         case KEY_semop:
3950             LOP(OP_SEMOP,XTERM);
3951
3952         case KEY_send:
3953             LOP(OP_SEND,XTERM);
3954
3955         case KEY_setpgrp:
3956             LOP(OP_SETPGRP,XTERM);
3957
3958         case KEY_setpriority:
3959             LOP(OP_SETPRIORITY,XTERM);
3960
3961         case KEY_sethostent:
3962             UNI(OP_SHOSTENT);
3963
3964         case KEY_setnetent:
3965             UNI(OP_SNETENT);
3966
3967         case KEY_setservent:
3968             UNI(OP_SSERVENT);
3969
3970         case KEY_setprotoent:
3971             UNI(OP_SPROTOENT);
3972
3973         case KEY_setpwent:
3974             FUN0(OP_SPWENT);
3975
3976         case KEY_setgrent:
3977             FUN0(OP_SGRENT);
3978
3979         case KEY_seekdir:
3980             LOP(OP_SEEKDIR,XTERM);
3981
3982         case KEY_setsockopt:
3983             LOP(OP_SSOCKOPT,XTERM);
3984
3985         case KEY_shift:
3986             UNI(OP_SHIFT);
3987
3988         case KEY_shmctl:
3989             LOP(OP_SHMCTL,XTERM);
3990
3991         case KEY_shmget:
3992             LOP(OP_SHMGET,XTERM);
3993
3994         case KEY_shmread:
3995             LOP(OP_SHMREAD,XTERM);
3996
3997         case KEY_shmwrite:
3998             LOP(OP_SHMWRITE,XTERM);
3999
4000         case KEY_shutdown:
4001             LOP(OP_SHUTDOWN,XTERM);
4002
4003         case KEY_sin:
4004             UNI(OP_SIN);
4005
4006         case KEY_sleep:
4007             UNI(OP_SLEEP);
4008
4009         case KEY_socket:
4010             LOP(OP_SOCKET,XTERM);
4011
4012         case KEY_socketpair:
4013             LOP(OP_SOCKPAIR,XTERM);
4014
4015         case KEY_sort:
4016             checkcomma(s,PL_tokenbuf,"subroutine name");
4017             s = skipspace(s);
4018             if (*s == ';' || *s == ')')         /* probably a close */
4019                 Perl_croak(aTHX_ "sort is now a reserved word");
4020             PL_expect = XTERM;
4021             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4022             LOP(OP_SORT,XREF);
4023
4024         case KEY_split:
4025             LOP(OP_SPLIT,XTERM);
4026
4027         case KEY_sprintf:
4028             LOP(OP_SPRINTF,XTERM);
4029
4030         case KEY_splice:
4031             LOP(OP_SPLICE,XTERM);
4032
4033         case KEY_sqrt:
4034             UNI(OP_SQRT);
4035
4036         case KEY_srand:
4037             UNI(OP_SRAND);
4038
4039         case KEY_stat:
4040             UNI(OP_STAT);
4041
4042         case KEY_study:
4043             PL_sawstudy++;
4044             UNI(OP_STUDY);
4045
4046         case KEY_substr:
4047             LOP(OP_SUBSTR,XTERM);
4048
4049         case KEY_format:
4050         case KEY_sub:
4051           really_sub:
4052             s = skipspace(s);
4053
4054             if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4055                 char tmpbuf[sizeof PL_tokenbuf];
4056                 PL_expect = XBLOCK;
4057                 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4058                 if (strchr(tmpbuf, ':'))
4059                     sv_setpv(PL_subname, tmpbuf);
4060                 else {
4061                     sv_setsv(PL_subname,PL_curstname);
4062                     sv_catpvn(PL_subname,"::",2);
4063                     sv_catpvn(PL_subname,tmpbuf,len);
4064                 }
4065                 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4066                 s = skipspace(s);
4067             }
4068             else {
4069                 PL_expect = XTERMBLOCK;
4070                 sv_setpv(PL_subname,"?");
4071             }
4072
4073             if (tmp == KEY_format) {
4074                 s = skipspace(s);
4075                 if (*s == '=')
4076                     PL_lex_formbrack = PL_lex_brackets + 1;
4077                 OPERATOR(FORMAT);
4078             }
4079
4080             /* Look for a prototype */
4081             if (*s == '(') {
4082                 char *p;
4083
4084                 s = scan_str(s);
4085                 if (!s) {
4086                     if (PL_lex_stuff)
4087                         SvREFCNT_dec(PL_lex_stuff);
4088                     PL_lex_stuff = Nullsv;
4089                     Perl_croak(aTHX_ "Prototype not terminated");
4090                 }
4091                 /* strip spaces */
4092                 d = SvPVX(PL_lex_stuff);
4093                 tmp = 0;
4094                 for (p = d; *p; ++p) {
4095                     if (!isSPACE(*p))
4096                         d[tmp++] = *p;
4097                 }
4098                 d[tmp] = '\0';
4099                 SvCUR(PL_lex_stuff) = tmp;
4100
4101                 PL_nexttoke++;
4102                 PL_nextval[1] = PL_nextval[0];
4103                 PL_nexttype[1] = PL_nexttype[0];
4104                 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4105                 PL_nexttype[0] = THING;
4106                 if (PL_nexttoke == 1) {
4107                     PL_lex_defer = PL_lex_state;
4108                     PL_lex_expect = PL_expect;
4109                     PL_lex_state = LEX_KNOWNEXT;
4110                 }
4111                 PL_lex_stuff = Nullsv;
4112             }
4113
4114             if (*SvPV(PL_subname,n_a) == '?') {
4115                 sv_setpv(PL_subname,"__ANON__");
4116                 TOKEN(ANONSUB);
4117             }
4118             PREBLOCK(SUB);
4119
4120         case KEY_system:
4121             set_csh();
4122             LOP(OP_SYSTEM,XREF);
4123
4124         case KEY_symlink:
4125             LOP(OP_SYMLINK,XTERM);
4126
4127         case KEY_syscall:
4128             LOP(OP_SYSCALL,XTERM);
4129
4130         case KEY_sysopen:
4131             LOP(OP_SYSOPEN,XTERM);
4132
4133         case KEY_sysseek:
4134             LOP(OP_SYSSEEK,XTERM);
4135
4136         case KEY_sysread:
4137             LOP(OP_SYSREAD,XTERM);
4138
4139         case KEY_syswrite:
4140             LOP(OP_SYSWRITE,XTERM);
4141
4142         case KEY_tr:
4143             s = scan_trans(s);
4144             TERM(sublex_start());
4145
4146         case KEY_tell:
4147             UNI(OP_TELL);
4148
4149         case KEY_telldir:
4150             UNI(OP_TELLDIR);
4151
4152         case KEY_tie:
4153             LOP(OP_TIE,XTERM);
4154
4155         case KEY_tied:
4156             UNI(OP_TIED);
4157
4158         case KEY_time:
4159             FUN0(OP_TIME);
4160
4161         case KEY_times:
4162             FUN0(OP_TMS);
4163
4164         case KEY_truncate:
4165             LOP(OP_TRUNCATE,XTERM);
4166
4167         case KEY_uc:
4168             UNI(OP_UC);
4169
4170         case KEY_ucfirst:
4171             UNI(OP_UCFIRST);
4172
4173         case KEY_untie:
4174             UNI(OP_UNTIE);
4175
4176         case KEY_until:
4177             yylval.ival = PL_curcop->cop_line;
4178             OPERATOR(UNTIL);
4179
4180         case KEY_unless:
4181             yylval.ival = PL_curcop->cop_line;
4182             OPERATOR(UNLESS);
4183
4184         case KEY_unlink:
4185             LOP(OP_UNLINK,XTERM);
4186
4187         case KEY_undef:
4188             UNI(OP_UNDEF);
4189
4190         case KEY_unpack:
4191             LOP(OP_UNPACK,XTERM);
4192
4193         case KEY_utime:
4194             LOP(OP_UTIME,XTERM);
4195
4196         case KEY_umask:
4197             if (ckWARN(WARN_OCTAL)) {
4198                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4199                 if (*d != '0' && isDIGIT(*d))
4200                     yywarn("umask: argument is missing initial 0");
4201             }
4202             UNI(OP_UMASK);
4203
4204         case KEY_unshift:
4205             LOP(OP_UNSHIFT,XTERM);
4206
4207         case KEY_use:
4208             if (PL_expect != XSTATE)
4209                 yyerror("\"use\" not allowed in expression");
4210             s = skipspace(s);
4211             if(isDIGIT(*s)) {
4212                 s = force_version(s);
4213                 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4214                     PL_nextval[PL_nexttoke].opval = Nullop;
4215                     force_next(WORD);
4216                 }
4217             }
4218             else {
4219                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4220                 s = force_version(s);
4221             }
4222             yylval.ival = 1;
4223             OPERATOR(USE);
4224
4225         case KEY_values:
4226             UNI(OP_VALUES);
4227
4228         case KEY_vec:
4229             PL_sawvec = TRUE;
4230             LOP(OP_VEC,XTERM);
4231
4232         case KEY_while:
4233             yylval.ival = PL_curcop->cop_line;
4234             OPERATOR(WHILE);
4235
4236         case KEY_warn:
4237             PL_hints |= HINT_BLOCK_SCOPE;
4238             LOP(OP_WARN,XTERM);
4239
4240         case KEY_wait:
4241             FUN0(OP_WAIT);
4242
4243         case KEY_waitpid:
4244             LOP(OP_WAITPID,XTERM);
4245
4246         case KEY_wantarray:
4247             FUN0(OP_WANTARRAY);
4248
4249         case KEY_write:
4250 #ifdef EBCDIC
4251         {
4252             static char ctl_l[2];
4253
4254             if (ctl_l[0] == '\0')
4255                 ctl_l[0] = toCTRL('L');
4256             gv_fetchpv(ctl_l,TRUE, SVt_PV);
4257         }
4258 #else
4259             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
4260 #endif
4261             UNI(OP_ENTERWRITE);
4262
4263         case KEY_x:
4264             if (PL_expect == XOPERATOR)
4265                 Mop(OP_REPEAT);
4266             check_uni();
4267             goto just_a_word;
4268
4269         case KEY_xor:
4270             yylval.ival = OP_XOR;
4271             OPERATOR(OROP);
4272
4273         case KEY_y:
4274             s = scan_trans(s);
4275             TERM(sublex_start());
4276         }
4277     }}
4278 }
4279
4280 I32
4281 Perl_keyword(pTHX_ register char *d, I32 len)
4282 {
4283     switch (*d) {
4284     case '_':
4285         if (d[1] == '_') {
4286             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
4287             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
4288             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
4289             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
4290             if (strEQ(d,"__END__"))             return KEY___END__;
4291         }
4292         break;
4293     case 'A':
4294         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
4295         break;
4296     case 'a':
4297         switch (len) {
4298         case 3:
4299             if (strEQ(d,"and"))                 return -KEY_and;
4300             if (strEQ(d,"abs"))                 return -KEY_abs;
4301             break;
4302         case 5:
4303             if (strEQ(d,"alarm"))               return -KEY_alarm;
4304             if (strEQ(d,"atan2"))               return -KEY_atan2;
4305             break;
4306         case 6:
4307             if (strEQ(d,"accept"))              return -KEY_accept;
4308             break;
4309         }
4310         break;
4311     case 'B':
4312         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
4313         break;
4314     case 'b':
4315         if (strEQ(d,"bless"))                   return -KEY_bless;
4316         if (strEQ(d,"bind"))                    return -KEY_bind;
4317         if (strEQ(d,"binmode"))                 return -KEY_binmode;
4318         break;
4319     case 'C':
4320         if (strEQ(d,"CORE"))                    return -KEY_CORE;
4321         break;
4322     case 'c':
4323         switch (len) {
4324         case 3:
4325             if (strEQ(d,"cmp"))                 return -KEY_cmp;
4326             if (strEQ(d,"chr"))                 return -KEY_chr;
4327             if (strEQ(d,"cos"))                 return -KEY_cos;
4328             break;
4329         case 4:
4330             if (strEQ(d,"chop"))                return KEY_chop;
4331             break;
4332         case 5:
4333             if (strEQ(d,"close"))               return -KEY_close;
4334             if (strEQ(d,"chdir"))               return -KEY_chdir;
4335             if (strEQ(d,"chomp"))               return KEY_chomp;
4336             if (strEQ(d,"chmod"))               return -KEY_chmod;
4337             if (strEQ(d,"chown"))               return -KEY_chown;
4338             if (strEQ(d,"crypt"))               return -KEY_crypt;
4339             break;
4340         case 6:
4341             if (strEQ(d,"chroot"))              return -KEY_chroot;
4342             if (strEQ(d,"caller"))              return -KEY_caller;
4343             break;
4344         case 7:
4345             if (strEQ(d,"connect"))             return -KEY_connect;
4346             break;
4347         case 8:
4348             if (strEQ(d,"closedir"))            return -KEY_closedir;
4349             if (strEQ(d,"continue"))            return -KEY_continue;
4350             break;
4351         }
4352         break;
4353     case 'D':
4354         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
4355         break;
4356     case 'd':
4357         switch (len) {
4358         case 2:
4359             if (strEQ(d,"do"))                  return KEY_do;
4360             break;
4361         case 3:
4362             if (strEQ(d,"die"))                 return -KEY_die;
4363             break;
4364         case 4:
4365             if (strEQ(d,"dump"))                return -KEY_dump;
4366             break;
4367         case 6:
4368             if (strEQ(d,"delete"))              return KEY_delete;
4369             break;
4370         case 7:
4371             if (strEQ(d,"defined"))             return KEY_defined;
4372             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
4373             break;
4374         case 8:
4375             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
4376             break;
4377         }
4378         break;
4379     case 'E':
4380         if (strEQ(d,"EQ")) { deprecate(d);      return -KEY_eq;}
4381         if (strEQ(d,"END"))                     return KEY_END;
4382         break;
4383     case 'e':
4384         switch (len) {
4385         case 2:
4386             if (strEQ(d,"eq"))                  return -KEY_eq;
4387             break;
4388         case 3:
4389             if (strEQ(d,"eof"))                 return -KEY_eof;
4390             if (strEQ(d,"exp"))                 return -KEY_exp;
4391             break;
4392         case 4:
4393             if (strEQ(d,"else"))                return KEY_else;
4394             if (strEQ(d,"exit"))                return -KEY_exit;
4395             if (strEQ(d,"eval"))                return KEY_eval;
4396             if (strEQ(d,"exec"))                return -KEY_exec;
4397             if (strEQ(d,"each"))                return KEY_each;
4398             break;
4399         case 5:
4400             if (strEQ(d,"elsif"))               return KEY_elsif;
4401             break;
4402         case 6:
4403             if (strEQ(d,"exists"))              return KEY_exists;
4404             if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif");
4405             break;
4406         case 8:
4407             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
4408             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
4409             break;
4410         case 9:
4411             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
4412             break;
4413         case 10:
4414             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
4415             if (strEQ(d,"endservent"))          return -KEY_endservent;
4416             break;
4417         case 11:
4418             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
4419             break;
4420         }
4421         break;
4422     case 'f':
4423         switch (len) {
4424         case 3:
4425             if (strEQ(d,"for"))                 return KEY_for;
4426             break;
4427         case 4:
4428             if (strEQ(d,"fork"))                return -KEY_fork;
4429             break;
4430         case 5:
4431             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
4432             if (strEQ(d,"flock"))               return -KEY_flock;
4433             break;
4434         case 6:
4435             if (strEQ(d,"format"))              return KEY_format;
4436             if (strEQ(d,"fileno"))              return -KEY_fileno;
4437             break;
4438         case 7:
4439             if (strEQ(d,"foreach"))             return KEY_foreach;
4440             break;
4441         case 8:
4442             if (strEQ(d,"formline"))            return -KEY_formline;
4443             break;
4444         }
4445         break;
4446     case 'G':
4447         if (len == 2) {
4448             if (strEQ(d,"GT")) { deprecate(