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