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