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(d);  return -KEY_gt;}
4449             if (strEQ(d,"GE")) { deprecate(d);  return -KEY_ge;}
4450         }
4451         break;
4452     case 'g':
4453         if (strnEQ(d,"get",3)) {
4454             d += 3;
4455             if (*d == 'p') {
4456                 switch (len) {
4457                 case 7:
4458                     if (strEQ(d,"ppid"))        return -KEY_getppid;
4459                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
4460                     break;
4461                 case 8:
4462                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
4463                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
4464                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
4465                     break;
4466                 case 11:
4467                     if (strEQ(d,"peername"))    return -KEY_getpeername;
4468                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
4469                     if (strEQ(d,"priority"))    return -KEY_getpriority;
4470                     break;
4471                 case 14:
4472                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4473                     break;
4474                 case 16:
4475                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4476                     break;
4477                 }
4478             }
4479             else if (*d == 'h') {
4480                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
4481                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
4482                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
4483             }
4484             else if (*d == 'n') {
4485                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
4486                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
4487                 if (strEQ(d,"netent"))          return -KEY_getnetent;
4488             }
4489             else if (*d == 's') {
4490                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
4491                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
4492                 if (strEQ(d,"servent"))         return -KEY_getservent;
4493                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
4494                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
4495             }
4496             else if (*d == 'g') {
4497                 if (strEQ(d,"grent"))           return -KEY_getgrent;
4498                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
4499                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
4500             }
4501             else if (*d == 'l') {
4502                 if (strEQ(d,"login"))           return -KEY_getlogin;
4503             }
4504             else if (strEQ(d,"c"))              return -KEY_getc;
4505             break;
4506         }
4507         switch (len) {
4508         case 2:
4509             if (strEQ(d,"gt"))                  return -KEY_gt;
4510             if (strEQ(d,"ge"))                  return -KEY_ge;
4511             break;
4512         case 4:
4513             if (strEQ(d,"grep"))                return KEY_grep;
4514             if (strEQ(d,"goto"))                return KEY_goto;
4515             if (strEQ(d,"glob"))                return KEY_glob;
4516             break;
4517         case 6:
4518             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
4519             break;
4520         }
4521         break;
4522     case 'h':
4523         if (strEQ(d,"hex"))                     return -KEY_hex;
4524         break;
4525     case 'I':
4526         if (strEQ(d,"INIT"))                    return KEY_INIT;
4527         break;
4528     case 'i':
4529         switch (len) {
4530         case 2:
4531             if (strEQ(d,"if"))                  return KEY_if;
4532             break;
4533         case 3:
4534             if (strEQ(d,"int"))                 return -KEY_int;
4535             break;
4536         case 5:
4537             if (strEQ(d,"index"))               return -KEY_index;
4538             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
4539             break;
4540         }
4541         break;
4542     case 'j':
4543         if (strEQ(d,"join"))                    return -KEY_join;
4544         break;
4545     case 'k':
4546         if (len == 4) {
4547             if (strEQ(d,"keys"))                return KEY_keys;
4548             if (strEQ(d,"kill"))                return -KEY_kill;
4549         }
4550         break;
4551     case 'L':
4552         if (len == 2) {
4553             if (strEQ(d,"LT")) { deprecate(d);  return -KEY_lt;}
4554             if (strEQ(d,"LE")) { deprecate(d);  return -KEY_le;}
4555         }
4556         break;
4557     case 'l':
4558         switch (len) {
4559         case 2:
4560             if (strEQ(d,"lt"))                  return -KEY_lt;
4561             if (strEQ(d,"le"))                  return -KEY_le;
4562             if (strEQ(d,"lc"))                  return -KEY_lc;
4563             break;
4564         case 3:
4565             if (strEQ(d,"log"))                 return -KEY_log;
4566             break;
4567         case 4:
4568             if (strEQ(d,"last"))                return KEY_last;
4569             if (strEQ(d,"link"))                return -KEY_link;
4570             if (strEQ(d,"lock"))                return -KEY_lock;
4571             break;
4572         case 5:
4573             if (strEQ(d,"local"))               return KEY_local;
4574             if (strEQ(d,"lstat"))               return -KEY_lstat;
4575             break;
4576         case 6:
4577             if (strEQ(d,"length"))              return -KEY_length;
4578             if (strEQ(d,"listen"))              return -KEY_listen;
4579             break;
4580         case 7:
4581             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
4582             break;
4583         case 9:
4584             if (strEQ(d,"localtime"))           return -KEY_localtime;
4585             break;
4586         }
4587         break;
4588     case 'm':
4589         switch (len) {
4590         case 1:                                 return KEY_m;
4591         case 2:
4592             if (strEQ(d,"my"))                  return KEY_my;
4593             break;
4594         case 3:
4595             if (strEQ(d,"map"))                 return KEY_map;
4596             break;
4597         case 5:
4598             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
4599             break;
4600         case 6:
4601             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
4602             if (strEQ(d,"msgget"))              return -KEY_msgget;
4603             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
4604             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
4605             break;
4606         }
4607         break;
4608     case 'N':
4609         if (strEQ(d,"NE")) { deprecate(d);      return -KEY_ne;}
4610         break;
4611     case 'n':
4612         if (strEQ(d,"next"))                    return KEY_next;
4613         if (strEQ(d,"ne"))                      return -KEY_ne;
4614         if (strEQ(d,"not"))                     return -KEY_not;
4615         if (strEQ(d,"no"))                      return KEY_no;
4616         break;
4617     case 'o':
4618         switch (len) {
4619         case 2:
4620             if (strEQ(d,"or"))                  return -KEY_or;
4621             break;
4622         case 3:
4623             if (strEQ(d,"ord"))                 return -KEY_ord;
4624             if (strEQ(d,"oct"))                 return -KEY_oct;
4625             if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4626                                                 return 0;}
4627             break;
4628         case 4:
4629             if (strEQ(d,"open"))                return -KEY_open;
4630             break;
4631         case 7:
4632             if (strEQ(d,"opendir"))             return -KEY_opendir;
4633             break;
4634         }
4635         break;
4636     case 'p':
4637         switch (len) {
4638         case 3:
4639             if (strEQ(d,"pop"))                 return KEY_pop;
4640             if (strEQ(d,"pos"))                 return KEY_pos;
4641             break;
4642         case 4:
4643             if (strEQ(d,"push"))                return KEY_push;
4644             if (strEQ(d,"pack"))                return -KEY_pack;
4645             if (strEQ(d,"pipe"))                return -KEY_pipe;
4646             break;
4647         case 5:
4648             if (strEQ(d,"print"))               return KEY_print;
4649             break;
4650         case 6:
4651             if (strEQ(d,"printf"))              return KEY_printf;
4652             break;
4653         case 7:
4654             if (strEQ(d,"package"))             return KEY_package;
4655             break;
4656         case 9:
4657             if (strEQ(d,"prototype"))           return KEY_prototype;
4658         }
4659         break;
4660     case 'q':
4661         if (len <= 2) {
4662             if (strEQ(d,"q"))                   return KEY_q;
4663             if (strEQ(d,"qr"))                  return KEY_qr;
4664             if (strEQ(d,"qq"))                  return KEY_qq;
4665             if (strEQ(d,"qw"))                  return KEY_qw;
4666             if (strEQ(d,"qx"))                  return KEY_qx;
4667         }
4668         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
4669         break;
4670     case 'r':
4671         switch (len) {
4672         case 3:
4673             if (strEQ(d,"ref"))                 return -KEY_ref;
4674             break;
4675         case 4:
4676             if (strEQ(d,"read"))                return -KEY_read;
4677             if (strEQ(d,"rand"))                return -KEY_rand;
4678             if (strEQ(d,"recv"))                return -KEY_recv;
4679             if (strEQ(d,"redo"))                return KEY_redo;
4680             break;
4681         case 5:
4682             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
4683             if (strEQ(d,"reset"))               return -KEY_reset;
4684             break;
4685         case 6:
4686             if (strEQ(d,"return"))              return KEY_return;
4687             if (strEQ(d,"rename"))              return -KEY_rename;
4688             if (strEQ(d,"rindex"))              return -KEY_rindex;
4689             break;
4690         case 7:
4691             if (strEQ(d,"require"))             return -KEY_require;
4692             if (strEQ(d,"reverse"))             return -KEY_reverse;
4693             if (strEQ(d,"readdir"))             return -KEY_readdir;
4694             break;
4695         case 8:
4696             if (strEQ(d,"readlink"))            return -KEY_readlink;
4697             if (strEQ(d,"readline"))            return -KEY_readline;
4698             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
4699             break;
4700         case 9:
4701             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
4702             break;
4703         }
4704         break;
4705     case 's':
4706         switch (d[1]) {
4707         case 0:                                 return KEY_s;
4708         case 'c':
4709             if (strEQ(d,"scalar"))              return KEY_scalar;
4710             break;
4711         case 'e':
4712             switch (len) {
4713             case 4:
4714                 if (strEQ(d,"seek"))            return -KEY_seek;
4715                 if (strEQ(d,"send"))            return -KEY_send;
4716                 break;
4717             case 5:
4718                 if (strEQ(d,"semop"))           return -KEY_semop;
4719                 break;
4720             case 6:
4721                 if (strEQ(d,"select"))          return -KEY_select;
4722                 if (strEQ(d,"semctl"))          return -KEY_semctl;
4723                 if (strEQ(d,"semget"))          return -KEY_semget;
4724                 break;
4725             case 7:
4726                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
4727                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
4728                 break;
4729             case 8:
4730                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
4731                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
4732                 break;
4733             case 9:
4734                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
4735                 break;
4736             case 10:
4737                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
4738                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
4739                 if (strEQ(d,"setservent"))      return -KEY_setservent;
4740                 break;
4741             case 11:
4742                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
4743                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
4744                 break;
4745             }
4746             break;
4747         case 'h':
4748             switch (len) {
4749             case 5:
4750                 if (strEQ(d,"shift"))           return KEY_shift;
4751                 break;
4752             case 6:
4753                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
4754                 if (strEQ(d,"shmget"))          return -KEY_shmget;
4755                 break;
4756             case 7:
4757                 if (strEQ(d,"shmread"))         return -KEY_shmread;
4758                 break;
4759             case 8:
4760                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
4761                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
4762                 break;
4763             }
4764             break;
4765         case 'i':
4766             if (strEQ(d,"sin"))                 return -KEY_sin;
4767             break;
4768         case 'l':
4769             if (strEQ(d,"sleep"))               return -KEY_sleep;
4770             break;
4771         case 'o':
4772             if (strEQ(d,"sort"))                return KEY_sort;
4773             if (strEQ(d,"socket"))              return -KEY_socket;
4774             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
4775             break;
4776         case 'p':
4777             if (strEQ(d,"split"))               return KEY_split;
4778             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
4779             if (strEQ(d,"splice"))              return KEY_splice;
4780             break;
4781         case 'q':
4782             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
4783             break;
4784         case 'r':
4785             if (strEQ(d,"srand"))               return -KEY_srand;
4786             break;
4787         case 't':
4788             if (strEQ(d,"stat"))                return -KEY_stat;
4789             if (strEQ(d,"study"))               return KEY_study;
4790             break;
4791         case 'u':
4792             if (strEQ(d,"substr"))              return -KEY_substr;
4793             if (strEQ(d,"sub"))                 return KEY_sub;
4794             break;
4795         case 'y':
4796             switch (len) {
4797             case 6:
4798                 if (strEQ(d,"system"))          return -KEY_system;
4799                 break;
4800             case 7:
4801                 if (strEQ(d,"symlink"))         return -KEY_symlink;
4802                 if (strEQ(d,"syscall"))         return -KEY_syscall;
4803                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
4804                 if (strEQ(d,"sysread"))         return -KEY_sysread;
4805                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
4806                 break;
4807             case 8:
4808                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
4809                 break;
4810             }
4811             break;
4812         }
4813         break;
4814     case 't':
4815         switch (len) {
4816         case 2:
4817             if (strEQ(d,"tr"))                  return KEY_tr;
4818             break;
4819         case 3:
4820             if (strEQ(d,"tie"))                 return KEY_tie;
4821             break;
4822         case 4:
4823             if (strEQ(d,"tell"))                return -KEY_tell;
4824             if (strEQ(d,"tied"))                return KEY_tied;
4825             if (strEQ(d,"time"))                return -KEY_time;
4826             break;
4827         case 5:
4828             if (strEQ(d,"times"))               return -KEY_times;
4829             break;
4830         case 7:
4831             if (strEQ(d,"telldir"))             return -KEY_telldir;
4832             break;
4833         case 8:
4834             if (strEQ(d,"truncate"))            return -KEY_truncate;
4835             break;
4836         }
4837         break;
4838     case 'u':
4839         switch (len) {
4840         case 2:
4841             if (strEQ(d,"uc"))                  return -KEY_uc;
4842             break;
4843         case 3:
4844             if (strEQ(d,"use"))                 return KEY_use;
4845             break;
4846         case 5:
4847             if (strEQ(d,"undef"))               return KEY_undef;
4848             if (strEQ(d,"until"))               return KEY_until;
4849             if (strEQ(d,"untie"))               return KEY_untie;
4850             if (strEQ(d,"utime"))               return -KEY_utime;
4851             if (strEQ(d,"umask"))               return -KEY_umask;
4852             break;
4853         case 6:
4854             if (strEQ(d,"unless"))              return KEY_unless;
4855             if (strEQ(d,"unpack"))              return -KEY_unpack;
4856             if (strEQ(d,"unlink"))              return -KEY_unlink;
4857             break;
4858         case 7:
4859             if (strEQ(d,"unshift"))             return KEY_unshift;
4860             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
4861             break;
4862         }
4863         break;
4864     case 'v':
4865         if (strEQ(d,"values"))                  return -KEY_values;
4866         if (strEQ(d,"vec"))                     return -KEY_vec;
4867         break;
4868     case 'w':
4869         switch (len) {
4870         case 4:
4871             if (strEQ(d,"warn"))                return -KEY_warn;
4872             if (strEQ(d,"wait"))                return -KEY_wait;
4873             break;
4874         case 5:
4875             if (strEQ(d,"while"))               return KEY_while;
4876             if (strEQ(d,"write"))               return -KEY_write;
4877             break;
4878         case 7:
4879             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
4880             break;
4881         case 9:
4882             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
4883             break;
4884         }
4885         break;
4886     case 'x':
4887         if (len == 1)                           return -KEY_x;
4888         if (strEQ(d,"xor"))                     return -KEY_xor;
4889         break;
4890     case 'y':
4891         if (len == 1)                           return KEY_y;
4892         break;
4893     case 'z':
4894         break;
4895     }
4896     return 0;
4897 }
4898
4899 STATIC void
4900 S_checkcomma(pTHX_ register char *s, char *name, char *what)
4901 {
4902     char *w;
4903
4904     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
4905         dTHR;                           /* only for ckWARN */
4906         if (ckWARN(WARN_SYNTAX)) {
4907             int level = 1;
4908             for (w = s+2; *w && level; w++) {
4909                 if (*w == '(')
4910                     ++level;
4911                 else if (*w == ')')
4912                     --level;
4913             }
4914             if (*w)
4915                 for (; *w && isSPACE(*w); w++) ;
4916             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
4917                 Perl_warner(aTHX_ WARN_SYNTAX, "%s (...) interpreted as function",name);
4918         }
4919     }
4920     while (s < PL_bufend && isSPACE(*s))
4921         s++;
4922     if (*s == '(')
4923         s++;
4924     while (s < PL_bufend && isSPACE(*s))
4925         s++;
4926     if (isIDFIRST_lazy(s)) {
4927         w = s++;
4928         while (isALNUM_lazy(s))
4929             s++;
4930         while (s < PL_bufend && isSPACE(*s))
4931             s++;
4932         if (*s == ',') {
4933             int kw;
4934             *s = '\0';
4935             kw = keyword(w, s - w) || get_cv(w, FALSE) != 0;
4936             *s = ',';
4937             if (kw)
4938                 return;
4939             Perl_croak(aTHX_ "No comma allowed after %s", what);
4940         }
4941     }
4942 }
4943
4944 STATIC SV *
4945 S_new_constant(pTHX_ char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4946 {
4947     dSP;
4948     HV *table = GvHV(PL_hintgv);                 /* ^H */
4949     BINOP myop;
4950     SV *res;
4951     bool oldcatch = CATCH_GET;
4952     SV **cvp;
4953     SV *cv, *typesv;
4954
4955     if (!table) {
4956         yyerror("%^H is not defined");
4957         return sv;
4958     }
4959     cvp = hv_fetch(table, key, strlen(key), FALSE);
4960     if (!cvp || !SvOK(*cvp)) {
4961         char buf[128];
4962         sprintf(buf,"$^H{%s} is not defined", key);
4963         yyerror(buf);
4964         return sv;
4965     }
4966     sv_2mortal(sv);                     /* Parent created it permanently */
4967     cv = *cvp;
4968     if (!pv)
4969         pv = sv_2mortal(newSVpvn(s, len));
4970     if (type)
4971         typesv = sv_2mortal(newSVpv(type, 0));
4972     else
4973         typesv = &PL_sv_undef;
4974     CATCH_SET(TRUE);
4975     Zero(&myop, 1, BINOP);
4976     myop.op_last = (OP *) &myop;
4977     myop.op_next = Nullop;
4978     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4979
4980     PUSHSTACKi(PERLSI_OVERLOAD);
4981     ENTER;
4982     SAVEOP();
4983     PL_op = (OP *) &myop;
4984     if (PERLDB_SUB && PL_curstash != PL_debstash)
4985         PL_op->op_private |= OPpENTERSUB_DB;
4986     PUTBACK;
4987     Perl_pp_pushmark(aTHX);
4988
4989     EXTEND(sp, 4);
4990     PUSHs(pv);
4991     PUSHs(sv);
4992     PUSHs(typesv);
4993     PUSHs(cv);
4994     PUTBACK;
4995
4996     if (PL_op = Perl_pp_entersub(aTHX))
4997       CALLRUNOPS(aTHX);
4998     LEAVE;
4999     SPAGAIN;
5000
5001     res = POPs;
5002     PUTBACK;
5003     CATCH_SET(oldcatch);
5004     POPSTACK;
5005
5006     if (!SvOK(res)) {
5007         char buf[128];
5008         sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5009         yyerror(buf);
5010     }
5011     return SvREFCNT_inc(res);
5012 }
5013
5014 STATIC char *
5015 S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5016 {
5017     register char *d = dest;
5018     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
5019     for (;;) {
5020         if (d >= e)
5021             Perl_croak(aTHX_ ident_too_long);
5022         if (isALNUM(*s))        /* UTF handled below */
5023             *d++ = *s++;
5024         else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5025             *d++ = ':';
5026             *d++ = ':';
5027             s++;
5028         }
5029         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5030             *d++ = *s++;
5031             *d++ = *s++;
5032         }
5033         else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5034             char *t = s + UTF8SKIP(s);
5035             while (*t & 0x80 && is_utf8_mark((U8*)t))
5036                 t += UTF8SKIP(t);
5037             if (d + (t - s) > e)
5038                 Perl_croak(aTHX_ ident_too_long);
5039             Copy(s, d, t - s, char);
5040             d += t - s;
5041             s = t;
5042         }
5043         else {
5044             *d = '\0';
5045             *slp = d - dest;
5046             return s;
5047         }
5048     }
5049 }
5050
5051 STATIC char *
5052 S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5053 {
5054     register char *d;
5055     register char *e;
5056     char *bracket = 0;
5057     char funny = *s++;
5058
5059     if (PL_lex_brackets == 0)
5060         PL_lex_fakebrack = 0;
5061     if (isSPACE(*s))
5062         s = skipspace(s);
5063     d = dest;
5064     e = d + destlen - 3;        /* two-character token, ending NUL */
5065     if (isDIGIT(*s)) {
5066         while (isDIGIT(*s)) {
5067             if (d >= e)
5068                 Perl_croak(aTHX_ ident_too_long);
5069             *d++ = *s++;
5070         }
5071     }
5072     else {
5073         for (;;) {
5074             if (d >= e)
5075                 Perl_croak(aTHX_ ident_too_long);
5076             if (isALNUM(*s))    /* UTF handled below */
5077                 *d++ = *s++;
5078             else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5079                 *d++ = ':';
5080                 *d++ = ':';
5081                 s++;
5082             }
5083             else if (*s == ':' && s[1] == ':') {
5084                 *d++ = *s++;
5085                 *d++ = *s++;
5086             }
5087             else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5088                 char *t = s + UTF8SKIP(s);
5089                 while (*t & 0x80 && is_utf8_mark((U8*)t))
5090                     t += UTF8SKIP(t);
5091                 if (d + (t - s) > e)
5092                     Perl_croak(aTHX_ ident_too_long);
5093                 Copy(s, d, t - s, char);
5094                 d += t - s;
5095                 s = t;
5096             }
5097             else
5098                 break;
5099         }
5100     }
5101     *d = '\0';
5102     d = dest;
5103     if (*d) {
5104         if (PL_lex_state != LEX_NORMAL)
5105             PL_lex_state = LEX_INTERPENDMAYBE;
5106         return s;
5107     }
5108     if (*s == '$' && s[1] &&
5109         (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5110     {
5111         return s;
5112     }
5113     if (*s == '{') {
5114         bracket = s;
5115         s++;
5116     }
5117     else if (ck_uni)
5118         check_uni();
5119     if (s < send)
5120         *d = *s++;
5121     d[1] = '\0';
5122     if (*d == '^' && *s && isCONTROLVAR(*s)) {
5123         *d = toCTRL(*s);
5124         s++;
5125     }
5126     if (bracket) {
5127         if (isSPACE(s[-1])) {
5128             while (s < send) {
5129                 char ch = *s++;
5130                 if (ch != ' ' && ch != '\t') {
5131                     *d = ch;
5132                     break;
5133                 }
5134             }
5135         }
5136         if (isIDFIRST_lazy(d)) {
5137             d++;
5138             if (UTF) {
5139                 e = s;
5140                 while (e < send && isALNUM_lazy(e) || *e == ':') {
5141                     e += UTF8SKIP(e);
5142                     while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5143                         e += UTF8SKIP(e);
5144                 }
5145                 Copy(s, d, e - s, char);
5146                 d += e - s;
5147                 s = e;
5148             }
5149             else {
5150                 while ((isALNUM(*s) || *s == ':') && d < e)
5151                     *d++ = *s++;
5152                 if (d >= e)
5153                     Perl_croak(aTHX_ ident_too_long);
5154             }
5155             *d = '\0';
5156             while (s < send && (*s == ' ' || *s == '\t')) s++;
5157             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5158                 dTHR;                   /* only for ckWARN */
5159                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5160                     char *brack = *s == '[' ? "[...]" : "{...}";
5161                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
5162                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5163                         funny, dest, brack, funny, dest, brack);
5164                 }
5165                 PL_lex_fakebrack = PL_lex_brackets+1;
5166                 bracket++;
5167                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5168                 return s;
5169             }
5170         }
5171         /* Handle extended ${^Foo} variables
5172          * 1999-02-27 mjd-perl-patch@plover.com */
5173         else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */
5174                  && isALNUM(*s))
5175         {
5176             d++;
5177             while (isALNUM(*s) && d < e) {
5178                 *d++ = *s++;
5179             }
5180             if (d >= e)
5181                 Perl_croak(aTHX_ ident_too_long);
5182             *d = '\0';
5183         }
5184         if (*s == '}') {
5185             s++;
5186             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5187                 PL_lex_state = LEX_INTERPEND;
5188             if (funny == '#')
5189                 funny = '@';
5190             if (PL_lex_state == LEX_NORMAL) {
5191                 dTHR;                   /* only for ckWARN */
5192                 if (ckWARN(WARN_AMBIGUOUS) &&
5193                     (keyword(dest, d - dest) || get_cv(dest, FALSE)))
5194                 {
5195                     Perl_warner(aTHX_ WARN_AMBIGUOUS,
5196                         "Ambiguous use of %c{%s} resolved to %c%s",
5197                         funny, dest, funny, dest);
5198                 }
5199             }
5200         }
5201         else {
5202             s = bracket;                /* let the parser handle it */
5203             *dest = '\0';
5204         }
5205     }
5206     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5207         PL_lex_state = LEX_INTERPEND;
5208     return s;
5209 }
5210
5211 void
5212 Perl_pmflag(pTHX_ U16 *pmfl, int ch)
5213 {
5214     if (ch == 'i')
5215         *pmfl |= PMf_FOLD;
5216     else if (ch == 'g')
5217         *pmfl |= PMf_GLOBAL;
5218     else if (ch == 'c')
5219         *pmfl |= PMf_CONTINUE;
5220     else if (ch == 'o')
5221         *pmfl |= PMf_KEEP;
5222     else if (ch == 'm')
5223         *pmfl |= PMf_MULTILINE;
5224     else if (ch == 's')
5225         *pmfl |= PMf_SINGLELINE;
5226     else if (ch == 'x')
5227         *pmfl |= PMf_EXTENDED;
5228 }
5229
5230 STATIC char *
5231 S_scan_pat(pTHX_ char *start, I32 type)
5232 {
5233     PMOP *pm;
5234     char *s;
5235
5236     s = scan_str(start);
5237     if (!s) {
5238         if (PL_lex_stuff)
5239             SvREFCNT_dec(PL_lex_stuff);
5240         PL_lex_stuff = Nullsv;
5241         Perl_croak(aTHX_ "Search pattern not terminated");
5242     }
5243
5244     pm = (PMOP*)newPMOP(type, 0);
5245     if (PL_multi_open == '?')
5246         pm->op_pmflags |= PMf_ONCE;
5247     if(type == OP_QR) {
5248         while (*s && strchr("iomsx", *s))
5249             pmflag(&pm->op_pmflags,*s++);
5250     }
5251     else {
5252         while (*s && strchr("iogcmsx", *s))
5253             pmflag(&pm->op_pmflags,*s++);
5254     }
5255     pm->op_pmpermflags = pm->op_pmflags;
5256
5257     PL_lex_op = (OP*)pm;
5258     yylval.ival = OP_MATCH;
5259     return s;
5260 }
5261
5262 STATIC char *
5263 S_scan_subst(pTHX_ char *start)
5264 {
5265     register char *s;
5266     register PMOP *pm;
5267     I32 first_start;
5268     I32 es = 0;
5269
5270     yylval.ival = OP_NULL;
5271
5272     s = scan_str(start);
5273
5274     if (!s) {
5275         if (PL_lex_stuff)
5276             SvREFCNT_dec(PL_lex_stuff);
5277         PL_lex_stuff = Nullsv;
5278         Perl_croak(aTHX_ "Substitution pattern not terminated");
5279     }
5280
5281     if (s[-1] == PL_multi_open)
5282         s--;
5283
5284     first_start = PL_multi_start;
5285     s = scan_str(s);
5286     if (!s) {
5287         if (PL_lex_stuff)
5288             SvREFCNT_dec(PL_lex_stuff);
5289         PL_lex_stuff = Nullsv;
5290         if (PL_lex_repl)
5291             SvREFCNT_dec(PL_lex_repl);
5292         PL_lex_repl = Nullsv;
5293         Perl_croak(aTHX_ "Substitution replacement not terminated");
5294     }
5295     PL_multi_start = first_start;       /* so whole substitution is taken together */
5296
5297     pm = (PMOP*)newPMOP(OP_SUBST, 0);
5298     while (*s) {
5299         if (*s == 'e') {
5300             s++;
5301             es++;
5302         }
5303         else if (strchr("iogcmsx", *s))
5304             pmflag(&pm->op_pmflags,*s++);
5305         else
5306             break;
5307     }
5308
5309     if (es) {
5310         SV *repl;
5311         PL_sublex_info.super_bufptr = s;
5312         PL_sublex_info.super_bufend = PL_bufend;
5313         PL_multi_end = 0;
5314         pm->op_pmflags |= PMf_EVAL;
5315         repl = newSVpvn("",0);
5316         while (es-- > 0)
5317             sv_catpv(repl, es ? "eval " : "do ");
5318         sv_catpvn(repl, "{ ", 2);
5319         sv_catsv(repl, PL_lex_repl);
5320         sv_catpvn(repl, " };", 2);
5321         SvEVALED_on(repl);
5322         SvREFCNT_dec(PL_lex_repl);
5323         PL_lex_repl = repl;
5324     }
5325
5326     pm->op_pmpermflags = pm->op_pmflags;
5327     PL_lex_op = (OP*)pm;
5328     yylval.ival = OP_SUBST;
5329     return s;
5330 }
5331
5332 STATIC char *
5333 S_scan_trans(pTHX_ char *start)
5334 {
5335     register char* s;
5336     OP *o;
5337     short *tbl;
5338     I32 squash;
5339     I32 del;
5340     I32 complement;
5341     I32 utf8;
5342     I32 count = 0;
5343
5344     yylval.ival = OP_NULL;
5345
5346     s = scan_str(start);
5347     if (!s) {
5348         if (PL_lex_stuff)
5349             SvREFCNT_dec(PL_lex_stuff);
5350         PL_lex_stuff = Nullsv;
5351         Perl_croak(aTHX_ "Transliteration pattern not terminated");
5352     }
5353     if (s[-1] == PL_multi_open)
5354         s--;
5355
5356     s = scan_str(s);
5357     if (!s) {
5358         if (PL_lex_stuff)
5359             SvREFCNT_dec(PL_lex_stuff);
5360         PL_lex_stuff = Nullsv;
5361         if (PL_lex_repl)
5362             SvREFCNT_dec(PL_lex_repl);
5363         PL_lex_repl = Nullsv;
5364         Perl_croak(aTHX_ "Transliteration replacement not terminated");
5365     }
5366
5367     if (UTF) {
5368         o = newSVOP(OP_TRANS, 0, 0);
5369         utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5370     }
5371     else {
5372         New(803,tbl,256,short);
5373         o = newPVOP(OP_TRANS, 0, (char*)tbl);
5374         utf8 = 0;
5375     }
5376
5377     complement = del = squash = 0;
5378     while (strchr("cdsCU", *s)) {
5379         if (*s == 'c')
5380             complement = OPpTRANS_COMPLEMENT;
5381         else if (*s == 'd')
5382             del = OPpTRANS_DELETE;
5383         else if (*s == 's')
5384             squash = OPpTRANS_SQUASH;
5385         else {
5386             switch (count++) {
5387             case 0:
5388                 if (*s == 'C')
5389                     utf8 &= ~OPpTRANS_FROM_UTF;
5390                 else
5391                     utf8 |= OPpTRANS_FROM_UTF;
5392                 break;
5393             case 1:
5394                 if (*s == 'C')
5395                     utf8 &= ~OPpTRANS_TO_UTF;
5396                 else
5397                     utf8 |= OPpTRANS_TO_UTF;
5398                 break;
5399             default:
5400                 Perl_croak(aTHX_ "Too many /C and /U options");
5401             }
5402         }
5403         s++;
5404     }
5405     o->op_private = del|squash|complement|utf8;
5406
5407     PL_lex_op = o;
5408     yylval.ival = OP_TRANS;
5409     return s;
5410 }
5411
5412 STATIC char *
5413 S_scan_heredoc(pTHX_ register char *s)
5414 {
5415     dTHR;
5416     SV *herewas;
5417     I32 op_type = OP_SCALAR;
5418     I32 len;
5419     SV *tmpstr;
5420     char term;
5421     register char *d;
5422     register char *e;
5423     char *peek;
5424     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5425
5426     s += 2;
5427     d = PL_tokenbuf;
5428     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5429     if (!outer)
5430         *d++ = '\n';
5431     for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5432     if (*peek && strchr("`'\"",*peek)) {
5433         s = peek;
5434         term = *s++;
5435         s = delimcpy(d, e, s, PL_bufend, term, &len);
5436         d += len;
5437         if (s < PL_bufend)
5438             s++;
5439     }
5440     else {
5441         if (*s == '\\')
5442             s++, term = '\'';
5443         else
5444             term = '"';
5445         if (!isALNUM_lazy(s))
5446             deprecate("bare << to mean <<\"\"");
5447         for (; isALNUM_lazy(s); s++) {
5448             if (d < e)
5449                 *d++ = *s;
5450         }
5451     }
5452     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5453         Perl_croak(aTHX_ "Delimiter for here document is too long");
5454     *d++ = '\n';
5455     *d = '\0';
5456     len = d - PL_tokenbuf;
5457 #ifndef PERL_STRICT_CR
5458     d = strchr(s, '\r');
5459     if (d) {
5460         char *olds = s;
5461         s = d;
5462         while (s < PL_bufend) {
5463             if (*s == '\r') {
5464                 *d++ = '\n';
5465                 if (*++s == '\n')
5466                     s++;
5467             }
5468             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
5469                 *d++ = *s++;
5470                 s++;
5471             }
5472             else
5473                 *d++ = *s++;
5474         }
5475         *d = '\0';
5476         PL_bufend = d;
5477         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5478         s = olds;
5479     }
5480 #endif
5481     d = "\n";
5482     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5483         herewas = newSVpvn(s,PL_bufend-s);
5484     else
5485         s--, herewas = newSVpvn(s,d-s);
5486     s += SvCUR(herewas);
5487
5488     tmpstr = NEWSV(87,79);
5489     sv_upgrade(tmpstr, SVt_PVIV);
5490     if (term == '\'') {
5491         op_type = OP_CONST;
5492         SvIVX(tmpstr) = -1;
5493     }
5494     else if (term == '`') {
5495         op_type = OP_BACKTICK;
5496         SvIVX(tmpstr) = '\\';
5497     }
5498
5499     CLINE;
5500     PL_multi_start = PL_curcop->cop_line;
5501     PL_multi_open = PL_multi_close = '<';
5502     term = *PL_tokenbuf;
5503     if (PL_lex_inwhat == OP_SUBST && PL_in_eval && !PL_rsfp) {
5504         char *bufptr = PL_sublex_info.super_bufptr;
5505         char *bufend = PL_sublex_info.super_bufend;
5506         char *olds = s - SvCUR(herewas);
5507         s = strchr(bufptr, '\n');
5508         if (!s)
5509             s = bufend;
5510         d = s;
5511         while (s < bufend &&
5512           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5513             if (*s++ == '\n')
5514                 PL_curcop->cop_line++;
5515         }
5516         if (s >= bufend) {
5517             PL_curcop->cop_line = PL_multi_start;
5518             missingterm(PL_tokenbuf);
5519         }
5520         sv_setpvn(herewas,bufptr,d-bufptr+1);
5521         sv_setpvn(tmpstr,d+1,s-d);
5522         s += len - 1;
5523         sv_catpvn(herewas,s,bufend-s);
5524         (void)strcpy(bufptr,SvPVX(herewas));
5525
5526         s = olds;
5527         goto retval;
5528     }
5529     else if (!outer) {
5530         d = s;
5531         while (s < PL_bufend &&
5532           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5533             if (*s++ == '\n')
5534                 PL_curcop->cop_line++;
5535         }
5536         if (s >= PL_bufend) {
5537             PL_curcop->cop_line = PL_multi_start;
5538             missingterm(PL_tokenbuf);
5539         }
5540         sv_setpvn(tmpstr,d+1,s-d);
5541         s += len - 1;
5542         PL_curcop->cop_line++;  /* the preceding stmt passes a newline */
5543
5544         sv_catpvn(herewas,s,PL_bufend-s);
5545         sv_setsv(PL_linestr,herewas);
5546         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5547         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5548     }
5549     else
5550         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
5551     while (s >= PL_bufend) {    /* multiple line string? */
5552         if (!outer ||
5553          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5554             PL_curcop->cop_line = PL_multi_start;
5555             missingterm(PL_tokenbuf);
5556         }
5557         PL_curcop->cop_line++;
5558         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5559 #ifndef PERL_STRICT_CR
5560         if (PL_bufend - PL_linestart >= 2) {
5561             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5562                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5563             {
5564                 PL_bufend[-2] = '\n';
5565                 PL_bufend--;
5566                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5567             }
5568             else if (PL_bufend[-1] == '\r')
5569                 PL_bufend[-1] = '\n';
5570         }
5571         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5572             PL_bufend[-1] = '\n';
5573 #endif
5574         if (PERLDB_LINE && PL_curstash != PL_debstash) {
5575             SV *sv = NEWSV(88,0);
5576
5577             sv_upgrade(sv, SVt_PVMG);
5578             sv_setsv(sv,PL_linestr);
5579             av_store(GvAV(PL_curcop->cop_filegv),
5580               (I32)PL_curcop->cop_line,sv);
5581         }
5582         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5583             s = PL_bufend - 1;
5584             *s = ' ';
5585             sv_catsv(PL_linestr,herewas);
5586             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5587         }
5588         else {
5589             s = PL_bufend;
5590             sv_catsv(tmpstr,PL_linestr);
5591         }
5592     }
5593     s++;
5594 retval:
5595     PL_multi_end = PL_curcop->cop_line;
5596     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5597         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5598         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5599     }
5600     SvREFCNT_dec(herewas);
5601     PL_lex_stuff = tmpstr;
5602     yylval.ival = op_type;
5603     return s;
5604 }
5605
5606 /* scan_inputsymbol
5607    takes: current position in input buffer
5608    returns: new position in input buffer
5609    side-effects: yylval and lex_op are set.
5610
5611    This code handles:
5612
5613    <>           read from ARGV
5614    <FH>         read from filehandle
5615    <pkg::FH>    read from package qualified filehandle
5616    <pkg'FH>     read from package qualified filehandle
5617    <$fh>        read from filehandle in $fh
5618    <*.h>        filename glob
5619
5620 */
5621
5622 STATIC char *
5623 S_scan_inputsymbol(pTHX_ char *start)
5624 {
5625     register char *s = start;           /* current position in buffer */
5626     register char *d;
5627     register char *e;
5628     char *end;
5629     I32 len;
5630
5631     d = PL_tokenbuf;                    /* start of temp holding space */
5632     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
5633     end = strchr(s, '\n');
5634     if (!end)
5635         end = PL_bufend;
5636     s = delimcpy(d, e, s + 1, end, '>', &len);  /* extract until > */
5637
5638     /* die if we didn't have space for the contents of the <>,
5639        or if it didn't end, or if we see a newline
5640     */
5641
5642     if (len >= sizeof PL_tokenbuf)
5643         Perl_croak(aTHX_ "Excessively long <> operator");
5644     if (s >= end)
5645         Perl_croak(aTHX_ "Unterminated <> operator");
5646
5647     s++;
5648
5649     /* check for <$fh>
5650        Remember, only scalar variables are interpreted as filehandles by
5651        this code.  Anything more complex (e.g., <$fh{$num}>) will be
5652        treated as a glob() call.
5653        This code makes use of the fact that except for the $ at the front,
5654        a scalar variable and a filehandle look the same.
5655     */
5656     if (*d == '$' && d[1]) d++;
5657
5658     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5659     while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5660         d++;
5661
5662     /* If we've tried to read what we allow filehandles to look like, and
5663        there's still text left, then it must be a glob() and not a getline.
5664        Use scan_str to pull out the stuff between the <> and treat it
5665        as nothing more than a string.
5666     */
5667
5668     if (d - PL_tokenbuf != len) {
5669         yylval.ival = OP_GLOB;
5670         set_csh();
5671         s = scan_str(start);
5672         if (!s)
5673            Perl_croak(aTHX_ "Glob not terminated");
5674         return s;
5675     }
5676     else {
5677         /* we're in a filehandle read situation */
5678         d = PL_tokenbuf;
5679
5680         /* turn <> into <ARGV> */
5681         if (!len)
5682             (void)strcpy(d,"ARGV");
5683
5684         /* if <$fh>, create the ops to turn the variable into a
5685            filehandle
5686         */
5687         if (*d == '$') {
5688             I32 tmp;
5689
5690             /* try to find it in the pad for this block, otherwise find
5691                add symbol table ops
5692             */
5693             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5694                 OP *o = newOP(OP_PADSV, 0);
5695                 o->op_targ = tmp;
5696                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
5697             }
5698             else {
5699                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5700                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5701                                             newUNOP(OP_RV2SV, 0,
5702                                                 newGVOP(OP_GV, 0, gv)));
5703             }
5704             PL_lex_op->op_flags |= OPf_SPECIAL;
5705             /* we created the ops in PL_lex_op, so make yylval.ival a null op */
5706             yylval.ival = OP_NULL;
5707         }
5708
5709         /* If it's none of the above, it must be a literal filehandle
5710            (<Foo::BAR> or <FOO>) so build a simple readline OP */
5711         else {
5712             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5713             PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5714             yylval.ival = OP_NULL;
5715         }
5716     }
5717
5718     return s;
5719 }
5720
5721
5722 /* scan_str
5723    takes: start position in buffer
5724    returns: position to continue reading from buffer
5725    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5726         updates the read buffer.
5727
5728    This subroutine pulls a string out of the input.  It is called for:
5729         q               single quotes           q(literal text)
5730         '               single quotes           'literal text'
5731         qq              double quotes           qq(interpolate $here please)
5732         "               double quotes           "interpolate $here please"
5733         qx              backticks               qx(/bin/ls -l)
5734         `               backticks               `/bin/ls -l`
5735         qw              quote words             @EXPORT_OK = qw( func() $spam )
5736         m//             regexp match            m/this/
5737         s///            regexp substitute       s/this/that/
5738         tr///           string transliterate    tr/this/that/
5739         y///            string transliterate    y/this/that/
5740         ($*@)           sub prototypes          sub foo ($)
5741         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
5742
5743    In most of these cases (all but <>, patterns and transliterate)
5744    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
5745    calls scan_str().  s/// makes yylex() call scan_subst() which calls
5746    scan_str().  tr/// and y/// make yylex() call scan_trans() which
5747    calls scan_str().
5748
5749    It skips whitespace before the string starts, and treats the first
5750    character as the delimiter.  If the delimiter is one of ([{< then
5751    the corresponding "close" character )]}> is used as the closing
5752    delimiter.  It allows quoting of delimiters, and if the string has
5753    balanced delimiters ([{<>}]) it allows nesting.
5754
5755    The lexer always reads these strings into lex_stuff, except in the
5756    case of the operators which take *two* arguments (s/// and tr///)
5757    when it checks to see if lex_stuff is full (presumably with the 1st
5758    arg to s or tr) and if so puts the string into lex_repl.
5759
5760 */
5761
5762 STATIC char *
5763 S_scan_str(pTHX_ char *start)
5764 {
5765     dTHR;
5766     SV *sv;                             /* scalar value: string */
5767     char *tmps;                         /* temp string, used for delimiter matching */
5768     register char *s = start;           /* current position in the buffer */
5769     register char term;                 /* terminating character */
5770     register char *to;                  /* current position in the sv's data */
5771     I32 brackets = 1;                   /* bracket nesting level */
5772
5773     /* skip space before the delimiter */
5774     if (isSPACE(*s))
5775         s = skipspace(s);
5776
5777     /* mark where we are, in case we need to report errors */
5778     CLINE;
5779
5780     /* after skipping whitespace, the next character is the terminator */
5781     term = *s;
5782     /* mark where we are */
5783     PL_multi_start = PL_curcop->cop_line;
5784     PL_multi_open = term;
5785
5786     /* find corresponding closing delimiter */
5787     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5788         term = tmps[5];
5789     PL_multi_close = term;
5790
5791     /* create a new SV to hold the contents.  87 is leak category, I'm
5792        assuming.  79 is the SV's initial length.  What a random number. */
5793     sv = NEWSV(87,79);
5794     sv_upgrade(sv, SVt_PVIV);
5795     SvIVX(sv) = term;
5796     (void)SvPOK_only(sv);               /* validate pointer */
5797
5798     /* move past delimiter and try to read a complete string */
5799     s++;
5800     for (;;) {
5801         /* extend sv if need be */
5802         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5803         /* set 'to' to the next character in the sv's string */
5804         to = SvPVX(sv)+SvCUR(sv);
5805
5806         /* if open delimiter is the close delimiter read unbridle */
5807         if (PL_multi_open == PL_multi_close) {
5808             for (; s < PL_bufend; s++,to++) {
5809                 /* embedded newlines increment the current line number */
5810                 if (*s == '\n' && !PL_rsfp)
5811                     PL_curcop->cop_line++;
5812                 /* handle quoted delimiters */
5813                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5814                     if (s[1] == term)
5815                         s++;
5816                 /* any other quotes are simply copied straight through */
5817                     else
5818                         *to++ = *s++;
5819                 }
5820                 /* terminate when run out of buffer (the for() condition), or
5821                    have found the terminator */
5822                 else if (*s == term)
5823                     break;
5824                 *to = *s;
5825             }
5826         }
5827
5828         /* if the terminator isn't the same as the start character (e.g.,
5829            matched brackets), we have to allow more in the quoting, and
5830            be prepared for nested brackets.
5831         */
5832         else {
5833             /* read until we run out of string, or we find the terminator */
5834             for (; s < PL_bufend; s++,to++) {
5835                 /* embedded newlines increment the line count */
5836                 if (*s == '\n' && !PL_rsfp)
5837                     PL_curcop->cop_line++;
5838                 /* backslashes can escape the open or closing characters */
5839                 if (*s == '\\' && s+1 < PL_bufend) {
5840                     if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5841                         s++;
5842                     else
5843                         *to++ = *s++;
5844                 }
5845                 /* allow nested opens and closes */
5846                 else if (*s == PL_multi_close && --brackets <= 0)
5847                     break;
5848                 else if (*s == PL_multi_open)
5849                     brackets++;
5850                 *to = *s;
5851             }
5852         }
5853         /* terminate the copied string and update the sv's end-of-string */
5854         *to = '\0';
5855         SvCUR_set(sv, to - SvPVX(sv));
5856
5857         /*
5858          * this next chunk reads more into the buffer if we're not done yet
5859          */
5860
5861         if (s < PL_bufend) break;       /* handle case where we are done yet :-) */
5862
5863 #ifndef PERL_STRICT_CR
5864         if (to - SvPVX(sv) >= 2) {
5865             if ((to[-2] == '\r' && to[-1] == '\n') ||
5866                 (to[-2] == '\n' && to[-1] == '\r'))
5867             {
5868                 to[-2] = '\n';
5869                 to--;
5870                 SvCUR_set(sv, to - SvPVX(sv));
5871             }
5872             else if (to[-1] == '\r')
5873                 to[-1] = '\n';
5874         }
5875         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5876             to[-1] = '\n';
5877 #endif
5878
5879         /* if we're out of file, or a read fails, bail and reset the current
5880            line marker so we can report where the unterminated string began
5881         */
5882         if (!PL_rsfp ||
5883          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5884             sv_free(sv);
5885             PL_curcop->cop_line = PL_multi_start;
5886             return Nullch;
5887         }
5888         /* we read a line, so increment our line counter */
5889         PL_curcop->cop_line++;
5890
5891         /* update debugger info */
5892         if (PERLDB_LINE && PL_curstash != PL_debstash) {
5893             SV *sv = NEWSV(88,0);
5894
5895             sv_upgrade(sv, SVt_PVMG);
5896             sv_setsv(sv,PL_linestr);
5897             av_store(GvAV(PL_curcop->cop_filegv),
5898               (I32)PL_curcop->cop_line, sv);
5899         }
5900
5901         /* having changed the buffer, we must update PL_bufend */
5902         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5903     }
5904
5905     /* at this point, we have successfully read the delimited string */
5906
5907     PL_multi_end = PL_curcop->cop_line;
5908     s++;
5909
5910     /* if we allocated too much space, give some back */
5911     if (SvCUR(sv) + 5 < SvLEN(sv)) {
5912         SvLEN_set(sv, SvCUR(sv) + 1);
5913         Renew(SvPVX(sv), SvLEN(sv), char);
5914     }
5915
5916     /* decide whether this is the first or second quoted string we've read
5917        for this op
5918     */
5919
5920     if (PL_lex_stuff)
5921         PL_lex_repl = sv;
5922     else
5923         PL_lex_stuff = sv;
5924     return s;
5925 }
5926
5927 /*
5928   scan_num
5929   takes: pointer to position in buffer
5930   returns: pointer to new position in buffer
5931   side-effects: builds ops for the constant in yylval.op
5932
5933   Read a number in any of the formats that Perl accepts:
5934
5935   0(x[0-7A-F]+)|([0-7]+)|(b[01])
5936   [\d_]+(\.[\d_]*)?[Ee](\d+)
5937
5938   Underbars (_) are allowed in decimal numbers.  If -w is on,
5939   underbars before a decimal point must be at three digit intervals.
5940
5941   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5942   thing it reads.
5943
5944   If it reads a number without a decimal point or an exponent, it will
5945   try converting the number to an integer and see if it can do so
5946   without loss of precision.
5947 */
5948
5949 char *
5950 Perl_scan_num(pTHX_ char *start)
5951 {
5952     register char *s = start;           /* current position in buffer */
5953     register char *d;                   /* destination in temp buffer */
5954     register char *e;                   /* end of temp buffer */
5955     I32 tryiv;                          /* used to see if it can be an int */
5956     NV value;                           /* number read, as a double */
5957     SV *sv;                             /* place to put the converted number */
5958     I32 floatit;                        /* boolean: int or float? */
5959     char *lastub = 0;                   /* position of last underbar */
5960     static char number_too_long[] = "Number too long";
5961
5962     /* We use the first character to decide what type of number this is */
5963
5964     switch (*s) {
5965     default:
5966       Perl_croak(aTHX_ "panic: scan_num");
5967
5968     /* if it starts with a 0, it could be an octal number, a decimal in
5969        0.13 disguise, or a hexadecimal number, or a binary number.
5970     */
5971     case '0':
5972         {
5973           /* variables:
5974              u          holds the "number so far"
5975              shift      the power of 2 of the base
5976                         (hex == 4, octal == 3, binary == 1)
5977              overflowed was the number more than we can hold?
5978
5979              Shift is used when we add a digit.  It also serves as an "are
5980              we in octal/hex/binary?" indicator to disallow hex characters
5981              when in octal mode.
5982            */
5983             UV u;
5984             I32 shift;
5985             bool overflowed = FALSE;
5986
5987             /* check for hex */
5988             if (s[1] == 'x') {
5989                 shift = 4;
5990                 s += 2;
5991             } else if (s[1] == 'b') {
5992                 shift = 1;
5993                 s += 2;
5994             }
5995             /* check for a decimal in disguise */
5996             else if (s[1] == '.')
5997                 goto decimal;
5998             /* so it must be octal */
5999             else
6000                 shift = 3;
6001             u = 0;
6002
6003             /* read the rest of the number */
6004             for (;;) {
6005                 UV n, b;        /* n is used in the overflow test, b is the digit we're adding on */
6006
6007                 switch (*s) {
6008
6009                 /* if we don't mention it, we're done */
6010                 default:
6011                     goto out;
6012
6013                 /* _ are ignored */
6014                 case '_':
6015                     s++;
6016                     break;
6017
6018                 /* 8 and 9 are not octal */
6019                 case '8': case '9':
6020                     if (shift == 3)
6021                         yyerror(Perl_form(aTHX_ "Illegal octal digit '%c'", *s));
6022                     else
6023                         if (shift == 1)
6024                             yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6025                     /* FALL THROUGH */
6026
6027                 /* octal digits */
6028                 case '2': case '3': case '4':
6029                 case '5': case '6': case '7':
6030                     if (shift == 1)
6031                         yyerror(Perl_form(aTHX_ "Illegal binary digit '%c'", *s));
6032                     /* FALL THROUGH */
6033
6034                 case '0': case '1':
6035                     b = *s++ & 15;              /* ASCII digit -> value of digit */
6036                     goto digit;
6037
6038                 /* hex digits */
6039                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
6040                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
6041                     /* make sure they said 0x */
6042                     if (shift != 4)
6043                         goto out;
6044                     b = (*s++ & 7) + 9;
6045
6046                     /* Prepare to put the digit we have onto the end
6047                        of the number so far.  We check for overflows.
6048                     */
6049
6050                   digit:
6051                     n = u << shift;     /* make room for the digit */
6052                     if (!overflowed && (n >> shift) != u
6053                         && !(PL_hints & HINT_NEW_BINARY)) {
6054                         Perl_warn(aTHX_ "Integer overflow in %s number",
6055                              (shift == 4) ? "hex"
6056                              : ((shift == 3) ? "octal" : "binary"));
6057                         overflowed = TRUE;
6058                     }
6059                     u = n | b;          /* add the digit to the end */
6060                     break;
6061                 }
6062             }
6063
6064           /* if we get here, we had success: make a scalar value from
6065              the number.
6066           */
6067           out:
6068             sv = NEWSV(92,0);
6069             sv_setuv(sv, u);
6070             if ( PL_hints & HINT_NEW_BINARY)
6071                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6072         }
6073         break;
6074
6075     /*
6076       handle decimal numbers.
6077       we're also sent here when we read a 0 as the first digit
6078     */
6079     case '1': case '2': case '3': case '4': case '5':
6080     case '6': case '7': case '8': case '9': case '.':
6081       decimal:
6082         d = PL_tokenbuf;
6083         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6084         floatit = FALSE;
6085
6086         /* read next group of digits and _ and copy into d */
6087         while (isDIGIT(*s) || *s == '_') {
6088             /* skip underscores, checking for misplaced ones
6089                if -w is on
6090             */
6091             if (*s == '_') {
6092                 dTHR;                   /* only for ckWARN */
6093                 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6094                     Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6095                 lastub = ++s;
6096             }
6097             else {
6098                 /* check for end of fixed-length buffer */
6099                 if (d >= e)
6100                     Perl_croak(aTHX_ number_too_long);
6101                 /* if we're ok, copy the character */
6102                 *d++ = *s++;
6103             }
6104         }
6105
6106         /* final misplaced underbar check */
6107         if (lastub && s - lastub != 3) {
6108             dTHR;
6109             if (ckWARN(WARN_SYNTAX))
6110                 Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number");
6111         }
6112
6113         /* read a decimal portion if there is one.  avoid
6114            3..5 being interpreted as the number 3. followed
6115            by .5
6116         */
6117         if (*s == '.' && s[1] != '.') {
6118             floatit = TRUE;
6119             *d++ = *s++;
6120
6121             /* copy, ignoring underbars, until we run out of
6122                digits.  Note: no misplaced underbar checks!
6123             */
6124             for (; isDIGIT(*s) || *s == '_'; s++) {
6125                 /* fixed length buffer check */
6126                 if (d >= e)
6127                     Perl_croak(aTHX_ number_too_long);
6128                 if (*s != '_')
6129                     *d++ = *s;
6130             }
6131         }
6132
6133         /* read exponent part, if present */
6134         if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6135             floatit = TRUE;
6136             s++;
6137
6138             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6139             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
6140
6141             /* allow positive or negative exponent */
6142             if (*s == '+' || *s == '-')
6143                 *d++ = *s++;
6144
6145             /* read digits of exponent (no underbars :-) */
6146             while (isDIGIT(*s)) {
6147                 if (d >= e)
6148                     Perl_croak(aTHX_ number_too_long);
6149                 *d++ = *s++;
6150             }
6151         }
6152
6153         /* terminate the string */
6154         *d = '\0';
6155
6156         /* make an sv from the string */
6157         sv = NEWSV(92,0);
6158
6159         value = Atof(PL_tokenbuf);
6160
6161         /*
6162            See if we can make do with an integer value without loss of
6163            precision.  We use I_V to cast to an int, because some
6164            compilers have issues.  Then we try casting it back and see
6165            if it was the same.  We only do this if we know we
6166            specifically read an integer.
6167
6168            Note: if floatit is true, then we don't need to do the
6169            conversion at all.
6170         */
6171         tryiv = I_V(value);
6172         if (!floatit && (NV)tryiv == value)
6173             sv_setiv(sv, tryiv);
6174         else
6175             sv_setnv(sv, value);
6176         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6177             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6178                               (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6179         break;
6180     }
6181
6182     /* make the op for the constant and return */
6183
6184     yylval.opval = newSVOP(OP_CONST, 0, sv);
6185
6186     return s;
6187 }
6188
6189 STATIC char *
6190 S_scan_formline(pTHX_ register char *s)
6191 {
6192     dTHR;
6193     register char *eol;
6194     register char *t;
6195     SV *stuff = newSVpvn("",0);
6196     bool needargs = FALSE;
6197
6198     while (!needargs) {
6199         if (*s == '.' || *s == '}') {
6200             /*SUPPRESS 530*/
6201 #ifdef PERL_STRICT_CR
6202             for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6203 #else
6204             for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6205 #endif
6206             if (*t == '\n' || t == PL_bufend)
6207                 break;
6208         }
6209         if (PL_in_eval && !PL_rsfp) {
6210             eol = strchr(s,'\n');
6211             if (!eol++)
6212                 eol = PL_bufend;
6213         }
6214         else
6215             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6216         if (*s != '#') {
6217             for (t = s; t < eol; t++) {
6218                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6219                     needargs = FALSE;
6220                     goto enough;        /* ~~ must be first line in formline */
6221                 }
6222                 if (*t == '@' || *t == '^')
6223                     needargs = TRUE;
6224             }
6225             sv_catpvn(stuff, s, eol-s);
6226         }
6227         s = eol;
6228         if (PL_rsfp) {
6229             s = filter_gets(PL_linestr, PL_rsfp, 0);
6230             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6231             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6232             if (!s) {
6233                 s = PL_bufptr;
6234                 yyerror("Format not terminated");
6235                 break;
6236             }
6237         }
6238         incline(s);
6239     }
6240   enough:
6241     if (SvCUR(stuff)) {
6242         PL_expect = XTERM;
6243         if (needargs) {
6244             PL_lex_state = LEX_NORMAL;
6245             PL_nextval[PL_nexttoke].ival = 0;
6246             force_next(',');
6247         }
6248         else
6249             PL_lex_state = LEX_FORMLINE;
6250         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6251         force_next(THING);
6252         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6253         force_next(LSTOP);
6254     }
6255     else {
6256         SvREFCNT_dec(stuff);
6257         PL_lex_formbrack = 0;
6258         PL_bufptr = s;
6259     }
6260     return s;
6261 }
6262
6263 STATIC void
6264 S_set_csh(pTHX)
6265 {
6266 #ifdef CSH
6267     if (!PL_cshlen)
6268         PL_cshlen = strlen(PL_cshname);
6269 #endif
6270 }
6271
6272 I32
6273 Perl_start_subparse(pTHX_ I32 is_format, U32 flags)
6274 {
6275     dTHR;
6276     I32 oldsavestack_ix = PL_savestack_ix;
6277     CV* outsidecv = PL_compcv;
6278     AV* comppadlist;
6279
6280     if (PL_compcv) {
6281         assert(SvTYPE(PL_compcv) == SVt_PVCV);
6282     }
6283     save_I32(&PL_subline);
6284     save_item(PL_subname);
6285     SAVEI32(PL_padix);
6286     SAVESPTR(PL_curpad);
6287     SAVESPTR(PL_comppad);
6288     SAVESPTR(PL_comppad_name);
6289     SAVESPTR(PL_compcv);
6290     SAVEI32(PL_comppad_name_fill);
6291     SAVEI32(PL_min_intro_pending);
6292     SAVEI32(PL_max_intro_pending);
6293     SAVEI32(PL_pad_reset_pending);
6294
6295     PL_compcv = (CV*)NEWSV(1104,0);
6296     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6297     CvFLAGS(PL_compcv) |= flags;
6298
6299     PL_comppad = newAV();
6300     av_push(PL_comppad, Nullsv);
6301     PL_curpad = AvARRAY(PL_comppad);
6302     PL_comppad_name = newAV();
6303     PL_comppad_name_fill = 0;
6304     PL_min_intro_pending = 0;
6305     PL_padix = 0;
6306     PL_subline = PL_curcop->cop_line;
6307 #ifdef USE_THREADS
6308     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
6309     PL_curpad[0] = (SV*)newAV();
6310     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
6311 #endif /* USE_THREADS */
6312
6313     comppadlist = newAV();
6314     AvREAL_off(comppadlist);
6315     av_store(comppadlist, 0, (SV*)PL_comppad_name);
6316     av_store(comppadlist, 1, (SV*)PL_comppad);
6317
6318     CvPADLIST(PL_compcv) = comppadlist;
6319     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6320 #ifdef USE_THREADS
6321     CvOWNER(PL_compcv) = 0;
6322     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6323     MUTEX_INIT(CvMUTEXP(PL_compcv));
6324 #endif /* USE_THREADS */
6325
6326     return oldsavestack_ix;
6327 }
6328
6329 int
6330 Perl_yywarn(pTHX_ char *s)
6331 {
6332     dTHR;
6333     --PL_error_count;
6334     PL_in_eval |= EVAL_WARNONLY;
6335     yyerror(s);
6336     PL_in_eval &= ~EVAL_WARNONLY;
6337     return 0;
6338 }
6339
6340 int
6341 Perl_yyerror(pTHX_ char *s)
6342 {
6343     dTHR;
6344     char *where = NULL;
6345     char *context = NULL;
6346     int contlen = -1;
6347     SV *msg;
6348
6349     if (!yychar || (yychar == ';' && !PL_rsfp))
6350         where = "at EOF";
6351     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6352       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6353         while (isSPACE(*PL_oldoldbufptr))
6354             PL_oldoldbufptr++;
6355         context = PL_oldoldbufptr;
6356         contlen = PL_bufptr - PL_oldoldbufptr;
6357     }
6358     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6359       PL_oldbufptr != PL_bufptr) {
6360         while (isSPACE(*PL_oldbufptr))
6361             PL_oldbufptr++;
6362         context = PL_oldbufptr;
6363         contlen = PL_bufptr - PL_oldbufptr;
6364     }
6365     else if (yychar > 255)
6366         where = "next token ???";
6367     else if ((yychar & 127) == 127) {
6368         if (PL_lex_state == LEX_NORMAL ||
6369            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6370             where = "at end of line";
6371         else if (PL_lex_inpat)
6372             where = "within pattern";
6373         else
6374             where = "within string";
6375     }
6376     else {
6377         SV *where_sv = sv_2mortal(newSVpvn("next char ", 10));
6378         if (yychar < 32)
6379             Perl_sv_catpvf(aTHX_ where_sv, "^%c", toCTRL(yychar));
6380         else if (isPRINT_LC(yychar))
6381             Perl_sv_catpvf(aTHX_ where_sv, "%c", yychar);
6382         else
6383             Perl_sv_catpvf(aTHX_ where_sv, "\\%03o", yychar & 255);
6384         where = SvPVX(where_sv);
6385     }
6386     msg = sv_2mortal(newSVpv(s, 0));
6387     Perl_sv_catpvf(aTHX_ msg, " at %_ line %ld, ",
6388               GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6389     if (context)
6390         Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context);
6391     else
6392         Perl_sv_catpvf(aTHX_ msg, "%s\n", where);
6393     if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6394         Perl_sv_catpvf(aTHX_ msg,
6395         "  (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6396                 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6397         PL_multi_end = 0;
6398     }
6399     if (PL_in_eval & EVAL_WARNONLY)
6400         Perl_warn(aTHX_ "%_", msg);
6401     else if (PL_in_eval)
6402         sv_catsv(ERRSV, msg);
6403     else
6404         PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6405     if (++PL_error_count >= 10)
6406         Perl_croak(aTHX_ "%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6407     PL_in_my = 0;
6408     PL_in_my_stash = Nullhv;
6409     return 0;
6410 }
6411
6412