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