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