toke.c

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