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