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 if (s <= oldbp)
 203         warn("\t(Missing operator before end of line?)\n");
 204     else
 205         warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
 206     PL_bufptr = oldbp;
 207 }
 208
 209 STATIC void
 210 missingterm(char *s)
 211 {
 212     char tmpbuf[3];
 213     char q;
 214     if (s) {
 215         char *nl = strrchr(s,'\n');
 216         if (nl)
 217             *nl = '\0';
 218     }
 219     else if (
 220 #ifdef EBCDIC
 221         iscntrl(PL_multi_close)
 222 #else
 223         PL_multi_close < 32 || PL_multi_close == 127
 224 #endif
 225         ) {
 226         *tmpbuf = '^';
 227         tmpbuf[1] = toCTRL(PL_multi_close);
 228         s = "\\n";
 229         tmpbuf[2] = '\0';
 230         s = tmpbuf;
 231     }
 232     else {
 233         *tmpbuf = PL_multi_close;
 234         tmpbuf[1] = '\0';
 235         s = tmpbuf;
 236     }
 237     q = strchr(s,'"') ? '\'' : '"';
 238     croak("Can't find string terminator %c%s%c anywhere before EOF",q,s,q);
 239 }
 240
 241 void
 242 deprecate(char *s)
 243 {
 244     dTHR;
 245     if (ckWARN(WARN_DEPRECATED))
 246         warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
 247 }
 248
 249 STATIC void
 250 depcom(void)
 251 {
 252     deprecate("comma-less variable list");
 253 }
 254
 255 #ifdef WIN32
 256
 257 STATIC I32
 258 win32_textfilter(int idx, SV *sv, int maxlen)
 259 {
 260  I32 count = FILTER_READ(idx+1, sv, maxlen);
 261  if (count > 0 && !maxlen)
 262   win32_strip_return(sv);
 263  return count;
 264 }
 265 #endif
 266
 267 #ifndef PERL_OBJECT
 268
 269 STATIC I32
 270 utf16_textfilter(int idx, SV *sv, int maxlen)
 271 {
 272     I32 count = FILTER_READ(idx+1, sv, maxlen);
 273     if (count) {
 274         U8* tmps;
 275         U8* tend;
 276         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
 277         tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
 278         sv_usepvn(sv, (char*)tmps, tend - tmps);
 279
 280     }
 281     return count;
 282 }
 283
 284 STATIC I32
 285 utf16rev_textfilter(int idx, SV *sv, int maxlen)
 286 {
 287     I32 count = FILTER_READ(idx+1, sv, maxlen);
 288     if (count) {
 289         U8* tmps;
 290         U8* tend;
 291         New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
 292         tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
 293         sv_usepvn(sv, (char*)tmps, tend - tmps);
 294
 295     }
 296     return count;
 297 }
 298
 299 #endif
 300
 301 void
 302 lex_start(SV *line)
 303 {
 304     dTHR;
 305     char *s;
 306     STRLEN len;
 307
 308     SAVEI32(PL_lex_dojoin);
 309     SAVEI32(PL_lex_brackets);
 310     SAVEI32(PL_lex_fakebrack);
 311     SAVEI32(PL_lex_casemods);
 312     SAVEI32(PL_lex_starts);
 313     SAVEI32(PL_lex_state);
 314     SAVESPTR(PL_lex_inpat);
 315     SAVEI32(PL_lex_inwhat);
 316     SAVEI16(PL_curcop->cop_line);
 317     SAVEPPTR(PL_bufptr);
 318     SAVEPPTR(PL_bufend);
 319     SAVEPPTR(PL_oldbufptr);
 320     SAVEPPTR(PL_oldoldbufptr);
 321     SAVEPPTR(PL_linestart);
 322     SAVESPTR(PL_linestr);
 323     SAVEPPTR(PL_lex_brackstack);
 324     SAVEPPTR(PL_lex_casestack);
 325     SAVEDESTRUCTOR(restore_rsfp, PL_rsfp);
 326     SAVESPTR(PL_lex_stuff);
 327     SAVEI32(PL_lex_defer);
 328     SAVESPTR(PL_lex_repl);
 329     SAVEDESTRUCTOR(restore_expect, PL_tokenbuf + PL_expect); /* encode as pointer */
 330     SAVEDESTRUCTOR(restore_lex_expect, PL_tokenbuf + PL_expect);
 331
 332     PL_lex_state = LEX_NORMAL;
 333     PL_lex_defer = 0;
 334     PL_expect = XSTATE;
 335     PL_lex_brackets = 0;
 336     PL_lex_fakebrack = 0;
 337     New(899, PL_lex_brackstack, 120, char);
 338     New(899, PL_lex_casestack, 12, char);
 339     SAVEFREEPV(PL_lex_brackstack);
 340     SAVEFREEPV(PL_lex_casestack);
 341     PL_lex_casemods = 0;
 342     *PL_lex_casestack = '\0';
 343     PL_lex_dojoin = 0;
 344     PL_lex_starts = 0;
 345     PL_lex_stuff = Nullsv;
 346     PL_lex_repl = Nullsv;
 347     PL_lex_inpat = 0;
 348     PL_lex_inwhat = 0;
 349     PL_linestr = line;
 350     if (SvREADONLY(PL_linestr))
 351         PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 352     s = SvPV(PL_linestr, len);
 353     if (len && s[len-1] != ';') {
 354         if (!(SvFLAGS(PL_linestr) & SVs_TEMP))
 355             PL_linestr = sv_2mortal(newSVsv(PL_linestr));
 356         sv_catpvn(PL_linestr, "\n;", 2);
 357     }
 358     SvTEMP_off(PL_linestr);
 359     PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
 360     PL_bufend = PL_bufptr + SvCUR(PL_linestr);
 361     SvREFCNT_dec(PL_rs);
 362     PL_rs = newSVpv("\n", 1);
 363     PL_rsfp = 0;
 364 }
 365
 366 void
 367 lex_end(void)
 368 {
 369     PL_doextract = FALSE;
 370 }
 371
 372 STATIC void
 373 restore_rsfp(void *f)
 374 {
 375     PerlIO *fp = (PerlIO*)f;
 376
 377     if (PL_rsfp == PerlIO_stdin())
 378         PerlIO_clearerr(PL_rsfp);
 379     else if (PL_rsfp && (PL_rsfp != fp))
 380         PerlIO_close(PL_rsfp);
 381     PL_rsfp = fp;
 382 }
 383
 384 STATIC void
 385 restore_expect(void *e)
 386 {
 387     /* a safe way to store a small integer in a pointer */
 388     PL_expect = (expectation)((char *)e - PL_tokenbuf);
 389 }
 390
 391 STATIC void
 392 restore_lex_expect(void *e)
 393 {
 394     /* a safe way to store a small integer in a pointer */
 395     PL_lex_expect = (expectation)((char *)e - PL_tokenbuf);
 396 }
 397
 398 STATIC void
 399 incline(char *s)
 400 {
 401     dTHR;
 402     char *t;
 403     char *n;
 404     char ch;
 405     int sawline = 0;
 406
 407     PL_curcop->cop_line++;
 408     if (*s++ != '#')
 409         return;
 410     while (*s == ' ' || *s == '\t') s++;
 411     if (strnEQ(s, "line ", 5)) {
 412         s += 5;
 413         sawline = 1;
 414     }
 415     if (!isDIGIT(*s))
 416         return;
 417     n = s;
 418     while (isDIGIT(*s))
 419         s++;
 420     while (*s == ' ' || *s == '\t')
 421         s++;
 422     if (*s == '"' && (t = strchr(s+1, '"')))
 423         s++;
 424     else {
 425         if (!sawline)
 426             return;             /* false alarm */
 427         for (t = s; !isSPACE(*t); t++) ;
 428     }
 429     ch = *t;
 430     *t = '\0';
 431     if (t - s > 0)
 432         PL_curcop->cop_filegv = gv_fetchfile(s);
 433     else
 434         PL_curcop->cop_filegv = gv_fetchfile(PL_origfilename);
 435     *t = ch;
 436     PL_curcop->cop_line = atoi(n)-1;
 437 }
 438
 439 STATIC char *
 440 skipspace(register char *s)
 441 {
 442     dTHR;
 443     if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 444         while (s < PL_bufend && (*s == ' ' || *s == '\t'))
 445             s++;
 446         return s;
 447     }
 448     for (;;) {
 449         STRLEN prevlen;
 450         while (s < PL_bufend && isSPACE(*s)) {
 451             if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
 452                 incline(s);
 453         }
 454         if (s < PL_bufend && *s == '#') {
 455             while (s < PL_bufend && *s != '\n')
 456                 s++;
 457             if (s < PL_bufend) {
 458                 s++;
 459                 if (PL_in_eval && !PL_rsfp) {
 460                     incline(s);
 461                     continue;
 462                 }
 463             }
 464         }
 465         if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
 466             return s;
 467         if ((s = filter_gets(PL_linestr, PL_rsfp, (prevlen = SvCUR(PL_linestr)))) == Nullch) {
 468             if (PL_minus_n || PL_minus_p) {
 469                 sv_setpv(PL_linestr,PL_minus_p ?
 470                          ";}continue{print or die qq(-p destination: $!\\n)" :
 471                          "");
 472                 sv_catpv(PL_linestr,";}");
 473                 PL_minus_n = PL_minus_p = 0;
 474             }
 475             else
 476                 sv_setpv(PL_linestr,";");
 477             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
 478             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
 479             if (PL_preprocess && !PL_in_eval)
 480                 (void)PerlProc_pclose(PL_rsfp);
 481             else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
 482                 PerlIO_clearerr(PL_rsfp);
 483             else
 484                 (void)PerlIO_close(PL_rsfp);
 485             PL_rsfp = Nullfp;
 486             return s;
 487         }
 488         PL_linestart = PL_bufptr = s + prevlen;
 489         PL_bufend = s + SvCUR(PL_linestr);
 490         s = PL_bufptr;
 491         incline(s);
 492         if (PERLDB_LINE && PL_curstash != PL_debstash) {
 493             SV *sv = NEWSV(85,0);
 494
 495             sv_upgrade(sv, SVt_PVMG);
 496             sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr);
 497             av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
 498         }
 499     }
 500 }
 501
 502 STATIC void
 503 check_uni(void) {
 504     char *s;
 505     char ch;
 506     char *t;
 507
 508     if (PL_oldoldbufptr != PL_last_uni)
 509         return;
 510     while (isSPACE(*PL_last_uni))
 511         PL_last_uni++;
 512     for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ;
 513     if ((t = strchr(s, '(')) && t < PL_bufptr)
 514         return;
 515     ch = *s;
 516     *s = '\0';
 517     warn("Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni);
 518     *s = ch;
 519 }
 520
 521 #ifdef CRIPPLED_CC
 522
 523 #undef UNI
 524 #define UNI(f) return uni(f,s)
 525
 526 STATIC int
 527 uni(I32 f, char *s)
 528 {
 529     yylval.ival = f;
 530     PL_expect = XTERM;
 531     PL_bufptr = s;
 532     PL_last_uni = PL_oldbufptr;
 533     PL_last_lop_op = f;
 534     if (*s == '(')
 535         return FUNC1;
 536     s = skipspace(s);
 537     if (*s == '(')
 538         return FUNC1;
 539     else
 540         return UNIOP;
 541 }
 542
 543 #endif /* CRIPPLED_CC */
 544
 545 #define LOP(f,x) return lop(f,x,s)
 546
 547 STATIC I32
 548 lop(I32 f, expectation x, char *s)
 549 {
 550     dTHR;
 551     yylval.ival = f;
 552     CLINE;
 553     PL_expect = x;
 554     PL_bufptr = s;
 555     PL_last_lop = PL_oldbufptr;
 556     PL_last_lop_op = f;
 557     if (PL_nexttoke)
 558         return LSTOP;
 559     if (*s == '(')
 560         return FUNC;
 561     s = skipspace(s);
 562     if (*s == '(')
 563         return FUNC;
 564     else
 565         return LSTOP;
 566 }
 567
 568 STATIC void
 569 force_next(I32 type)
 570 {
 571     PL_nexttype[PL_nexttoke] = type;
 572     PL_nexttoke++;
 573     if (PL_lex_state != LEX_KNOWNEXT) {
 574         PL_lex_defer = PL_lex_state;
 575         PL_lex_expect = PL_expect;
 576         PL_lex_state = LEX_KNOWNEXT;
 577     }
 578 }
 579
 580 STATIC char *
 581 force_word(register char *start, int token, int check_keyword, int allow_pack, int allow_initial_tick)
 582 {
 583     register char *s;
 584     STRLEN len;
 585
 586     start = skipspace(start);
 587     s = start;
 588     if (isIDFIRST_lazy(s) ||
 589         (allow_pack && *s == ':') ||
 590         (allow_initial_tick && *s == '\'') )
 591     {
 592         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len);
 593         if (check_keyword && keyword(PL_tokenbuf, len))
 594             return start;
 595         if (token == METHOD) {
 596             s = skipspace(s);
 597             if (*s == '(')
 598                 PL_expect = XTERM;
 599             else {
 600                 PL_expect = XOPERATOR;
 601                 force_next(')');
 602                 force_next('(');
 603             }
 604         }
 605         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0));
 606         PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE;
 607         force_next(token);
 608     }
 609     return s;
 610 }
 611
 612 STATIC void
 613 force_ident(register char *s, int kind)
 614 {
 615     if (s && *s) {
 616         OP* o = (OP*)newSVOP(OP_CONST, 0, newSVpv(s,0));
 617         PL_nextval[PL_nexttoke].opval = o;
 618         force_next(WORD);
 619         if (kind) {
 620             dTHR;               /* just for in_eval */
 621             o->op_private = OPpCONST_ENTERED;
 622             /* XXX see note in pp_entereval() for why we forgo typo
 623                warnings if the symbol must be introduced in an eval.
 624                GSAR 96-10-12 */
 625             gv_fetchpv(s, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
 626                 kind == '$' ? SVt_PV :
 627                 kind == '@' ? SVt_PVAV :
 628                 kind == '%' ? SVt_PVHV :
 629                               SVt_PVGV
 630                 );
 631         }
 632     }
 633 }
 634
 635 STATIC char *
 636 force_version(char *s)
 637 {
 638     OP *version = Nullop;
 639
 640     s = skipspace(s);
 641
 642     /* default VERSION number -- GBARR */
 643
 644     if(isDIGIT(*s)) {
 645         char *d;
 646         int c;
 647         for( d=s, c = 1; isDIGIT(*d) || *d == '_' || (*d == '.' && c--); d++);
 648         if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') {
 649             s = scan_num(s);
 650             /* real VERSION number -- GBARR */
 651             version = yylval.opval;
 652         }
 653     }
 654
 655     /* NOTE: The parser sees the package name and the VERSION swapped */
 656     PL_nextval[PL_nexttoke].opval = version;
 657     force_next(WORD);
 658
 659     return (s);
 660 }
 661
 662 STATIC SV *
 663 tokeq(SV *sv)
 664 {
 665     register char *s;
 666     register char *send;
 667     register char *d;
 668     STRLEN len = 0;
 669     SV *pv = sv;
 670
 671     if (!SvLEN(sv))
 672         goto finish;
 673
 674     s = SvPV_force(sv, len);
 675     if (SvIVX(sv) == -1)
 676         goto finish;
 677     send = s + len;
 678     while (s < send && *s != '\\')
 679         s++;
 680     if (s == send)
 681         goto finish;
 682     d = s;
 683     if ( PL_hints & HINT_NEW_STRING )
 684         pv = sv_2mortal(newSVpv(SvPVX(pv), len));
 685     while (s < send) {
 686         if (*s == '\\') {
 687             if (s + 1 < send && (s[1] == '\\'))
 688                 s++;            /* all that, just for this */
 689         }
 690         *d++ = *s++;
 691     }
 692     *d = '\0';
 693     SvCUR_set(sv, d - SvPVX(sv));
 694   finish:
 695     if ( PL_hints & HINT_NEW_STRING )
 696        return new_constant(NULL, 0, "q", sv, pv, "q");
 697     return sv;
 698 }
 699
 700 STATIC I32
 701 sublex_start(void)
 702 {
 703     register I32 op_type = yylval.ival;
 704
 705     if (op_type == OP_NULL) {
 706         yylval.opval = PL_lex_op;
 707         PL_lex_op = Nullop;
 708         return THING;
 709     }
 710     if (op_type == OP_CONST || op_type == OP_READLINE) {
 711         SV *sv = tokeq(PL_lex_stuff);
 712
 713         if (SvTYPE(sv) == SVt_PVIV) {
 714             /* Overloaded constants, nothing fancy: Convert to SVt_PV: */
 715             STRLEN len;
 716             char *p;
 717             SV *nsv;
 718
 719             p = SvPV(sv, len);
 720             nsv = newSVpv(p, len);
 721             SvREFCNT_dec(sv);
 722             sv = nsv;
 723         }
 724         yylval.opval = (OP*)newSVOP(op_type, 0, sv);
 725         PL_lex_stuff = Nullsv;
 726         return THING;
 727     }
 728
 729     PL_sublex_info.super_state = PL_lex_state;
 730     PL_sublex_info.sub_inwhat = op_type;
 731     PL_sublex_info.sub_op = PL_lex_op;
 732     PL_lex_state = LEX_INTERPPUSH;
 733
 734     PL_expect = XTERM;
 735     if (PL_lex_op) {
 736         yylval.opval = PL_lex_op;
 737         PL_lex_op = Nullop;
 738         return PMFUNC;
 739     }
 740     else
 741         return FUNC;
 742 }
 743
 744 STATIC I32
 745 sublex_push(void)
 746 {
 747     dTHR;
 748     ENTER;
 749
 750     PL_lex_state = PL_sublex_info.super_state;
 751     SAVEI32(PL_lex_dojoin);
 752     SAVEI32(PL_lex_brackets);
 753     SAVEI32(PL_lex_fakebrack);
 754     SAVEI32(PL_lex_casemods);
 755     SAVEI32(PL_lex_starts);
 756     SAVEI32(PL_lex_state);
 757     SAVESPTR(PL_lex_inpat);
 758     SAVEI32(PL_lex_inwhat);
 759     SAVEI16(PL_curcop->cop_line);
 760     SAVEPPTR(PL_bufptr);
 761     SAVEPPTR(PL_oldbufptr);
 762     SAVEPPTR(PL_oldoldbufptr);
 763     SAVEPPTR(PL_linestart);
 764     SAVESPTR(PL_linestr);
 765     SAVEPPTR(PL_lex_brackstack);
 766     SAVEPPTR(PL_lex_casestack);
 767
 768     PL_linestr = PL_lex_stuff;
 769     PL_lex_stuff = Nullsv;
 770
 771     PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
 772     PL_bufend += SvCUR(PL_linestr);
 773     SAVEFREESV(PL_linestr);
 774
 775     PL_lex_dojoin = FALSE;
 776     PL_lex_brackets = 0;
 777     PL_lex_fakebrack = 0;
 778     New(899, PL_lex_brackstack, 120, char);
 779     New(899, PL_lex_casestack, 12, char);
 780     SAVEFREEPV(PL_lex_brackstack);
 781     SAVEFREEPV(PL_lex_casestack);
 782     PL_lex_casemods = 0;
 783     *PL_lex_casestack = '\0';
 784     PL_lex_starts = 0;
 785     PL_lex_state = LEX_INTERPCONCAT;
 786     PL_curcop->cop_line = PL_multi_start;
 787
 788     PL_lex_inwhat = PL_sublex_info.sub_inwhat;
 789     if (PL_lex_inwhat == OP_MATCH || PL_lex_inwhat == OP_QR || PL_lex_inwhat == OP_SUBST)
 790         PL_lex_inpat = PL_sublex_info.sub_op;
 791     else
 792         PL_lex_inpat = Nullop;
 793
 794     return '(';
 795 }
 796
 797 STATIC I32
 798 sublex_done(void)
 799 {
 800     if (!PL_lex_starts++) {
 801         PL_expect = XOPERATOR;
 802         yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv("",0));
 803         return THING;
 804     }
 805
 806     if (PL_lex_casemods) {              /* oops, we've got some unbalanced parens */
 807         PL_lex_state = LEX_INTERPCASEMOD;
 808         return yylex(PERL_YYLEX_PARAM);
 809     }
 810
 811     /* Is there a right-hand side to take care of? */
 812     if (PL_lex_repl && (PL_lex_inwhat == OP_SUBST || PL_lex_inwhat == OP_TRANS)) {
 813         PL_linestr = PL_lex_repl;
 814         PL_lex_inpat = 0;
 815         PL_bufend = PL_bufptr = PL_oldbufptr = PL_oldoldbufptr = PL_linestart = SvPVX(PL_linestr);
 816         PL_bufend += SvCUR(PL_linestr);
 817         SAVEFREESV(PL_linestr);
 818         PL_lex_dojoin = FALSE;
 819         PL_lex_brackets = 0;
 820         PL_lex_fakebrack = 0;
 821         PL_lex_casemods = 0;
 822         *PL_lex_casestack = '\0';
 823         PL_lex_starts = 0;
 824         if (SvCOMPILED(PL_lex_repl)) {
 825             PL_lex_state = LEX_INTERPNORMAL;
 826             PL_lex_starts++;
 827             /*  we don't clear PL_lex_repl here, so that we can check later
 828                 whether this is an evalled subst; that means we rely on the
 829                 logic to ensure sublex_done() is called again only via the
 830                 branch (in yylex()) that clears PL_lex_repl, else we'll loop */
 831         }
 832         else {
 833             PL_lex_state = LEX_INTERPCONCAT;
 834             PL_lex_repl = Nullsv;
 835         }
 836         return ',';
 837     }
 838     else {
 839         LEAVE;
 840         PL_bufend = SvPVX(PL_linestr);
 841         PL_bufend += SvCUR(PL_linestr);
 842         PL_expect = XOPERATOR;
 843         return ')';
 844     }
 845 }
 846
 847 /*
 848   scan_const
 849
 850   Extracts a pattern, double-quoted string, or transliteration.  This
 851   is terrifying code.
 852
 853   It looks at lex_inwhat and PL_lex_inpat to find out whether it's
 854   processing a pattern (PL_lex_inpat is true), a transliteration
 855   (lex_inwhat & OP_TRANS is true), or a double-quoted string.
 856
 857   Returns a pointer to the character scanned up to. Iff this is
 858   advanced from the start pointer supplied (ie if anything was
 859   successfully parsed), will leave an OP for the substring scanned
 860   in yylval. Caller must intuit reason for not parsing further
 861   by looking at the next characters herself.
 862
 863   In patterns:
 864     backslashes:
 865       double-quoted style: \r and \n
 866       regexp special ones: \D \s
 867       constants: \x3
 868       backrefs: \1 (deprecated in substitution replacements)
 869       case and quoting: \U \Q \E
 870     stops on @ and $, but not for $ as tail anchor
 871
 872   In transliterations:
 873     characters are VERY literal, except for - not at the start or end
 874     of the string, which indicates a range.  scan_const expands the
 875     range to the full set of intermediate characters.
 876
 877   In double-quoted strings:
 878     backslashes:
 879       double-quoted style: \r and \n
 880       constants: \x3
 881       backrefs: \1 (deprecated)
 882       case and quoting: \U \Q \E
 883     stops on @ and $
 884
 885   scan_const does *not* construct ops to handle interpolated strings.
 886   It stops processing as soon as it finds an embedded $ or @ variable
 887   and leaves it to the caller to work out what's going on.
 888
 889   @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @:foo.
 890
 891   $ in pattern could be $foo or could be tail anchor.  Assumption:
 892   it's a tail anchor if $ is the last thing in the string, or if it's
 893   followed by one of ")| \n\t"
 894
 895   \1 (backreferences) are turned into $1
 896
 897   The structure of the code is
 898       while (there's a character to process) {
 899           handle transliteration ranges
 900           skip regexp comments
 901           skip # initiated comments in //x patterns
 902           check for embedded @foo
 903           check for embedded scalars
 904           if (backslash) {
 905               leave intact backslashes from leave (below)
 906               deprecate \1 in strings and sub replacements
 907               handle string-changing backslashes \l \U \Q \E, etc.
 908               switch (what was escaped) {
 909                   handle - in a transliteration (becomes a literal -)
 910                   handle \132 octal characters
 911                   handle 0x15 hex characters
 912                   handle \cV (control V)
 913                   handle printf backslashes (\f, \r, \n, etc)
 914               } (end switch)
 915           } (end if backslash)
 916     } (end while character to read)
 917
 918 */
 919
 920 STATIC char *
 921 scan_const(char *start)
 922 {
 923     register char *send = PL_bufend;            /* end of the constant */
 924     SV *sv = NEWSV(93, send - start);           /* sv for the constant */
 925     register char *s = start;                   /* start of the constant */
 926     register char *d = SvPVX(sv);               /* destination for copies */
 927     bool dorange = FALSE;                       /* are we in a translit range? */
 928     I32 len;                                    /* ? */
 929     I32 utf = PL_lex_inwhat == OP_TRANS
 930         ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
 931         : UTF;
 932     I32 thisutf = PL_lex_inwhat == OP_TRANS
 933         ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF))
 934         : UTF;
 935
 936     /* leaveit is the set of acceptably-backslashed characters */
 937     char *leaveit =
 938         PL_lex_inpat
 939             ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#"
 940             : "";
 941
 942     while (s < send || dorange) {
 943         /* get transliterations out of the way (they're most literal) */
 944         if (PL_lex_inwhat == OP_TRANS) {
 945             /* expand a range A-Z to the full set of characters.  AIE! */
 946             if (dorange) {
 947                 I32 i;                          /* current expanded character */
 948                 I32 min;                        /* first character in range */
 949                 I32 max;                        /* last character in range */
 950
 951                 i = d - SvPVX(sv);              /* remember current offset */
 952                 SvGROW(sv, SvLEN(sv) + 256);    /* expand the sv -- there'll never be more'n 256 chars in a range for it to grow by */
 953                 d = SvPVX(sv) + i;              /* restore d after the grow potentially has changed the ptr */
 954                 d -= 2;                         /* eat the first char and the - */
 955
 956                 min = (U8)*d;                   /* first char in range */
 957                 max = (U8)d[1];                 /* last char in range  */
 958
 959 #ifndef ASCIIish
 960                 if ((isLOWER(min) && isLOWER(max)) ||
 961                     (isUPPER(min) && isUPPER(max))) {
 962                     if (isLOWER(min)) {
 963                         for (i = min; i <= max; i++)
 964                             if (isLOWER(i))
 965                                 *d++ = i;
 966                     } else {
 967                         for (i = min; i <= max; i++)
 968                             if (isUPPER(i))
 969                                 *d++ = i;
 970                     }
 971                 }
 972                 else
 973 #endif
 974                     for (i = min; i <= max; i++)
 975                         *d++ = i;
 976
 977                 /* mark the range as done, and continue */
 978                 dorange = FALSE;
 979                 continue;
 980             }
 981
 982             /* range begins (ignore - as first or last char) */
 983             else if (*s == '-' && s+1 < send  && s != start) {
 984                 if (utf) {
 985                     *d++ = (char)0xff;  /* use illegal utf8 byte--see pmtrans */
 986                     s++;
 987                     continue;
 988                 }
 989                 dorange = TRUE;
 990                 s++;
 991             }
 992         }
 993
 994         /* if we get here, we're not doing a transliteration */
 995
 996         /* skip for regexp comments /(?#comment)/ and code /(?{code})/,
 997            except for the last char, which will be done separately. */
 998         else if (*s == '(' && PL_lex_inpat && s[1] == '?') {
 999             if (s[2] == '#') {
1000                 while (s < send && *s != ')')
1001                     *d++ = *s++;
1002             } else if (s[2] == '{'
1003                        || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */
1004                 I32 count = 1;
1005                 char *regparse = s + (s[2] == '{' ? 3 : 4);
1006                 char c;
1007
1008                 while (count && (c = *regparse)) {
1009                     if (c == '\\' && regparse[1])
1010                         regparse++;
1011                     else if (c == '{')
1012                         count++;
1013                     else if (c == '}')
1014                         count--;
1015                     regparse++;
1016                 }
1017                 if (*regparse != ')') {
1018                     regparse--;         /* Leave one char for continuation. */
1019                     yyerror("Sequence (?{...}) not terminated or not {}-balanced");
1020                 }
1021                 while (s < regparse)
1022                     *d++ = *s++;
1023             }
1024         }
1025
1026         /* likewise skip #-initiated comments in //x patterns */
1027         else if (*s == '#' && PL_lex_inpat &&
1028           ((PMOP*)PL_lex_inpat)->op_pmflags & PMf_EXTENDED) {
1029             while (s+1 < send && *s != '\n')
1030                 *d++ = *s++;
1031         }
1032
1033         /* check for embedded arrays (@foo, @:foo, @'foo, @{foo}, @$foo) */
1034         else if (*s == '@' && s[1] && (isALNUM_lazy(s+1) || strchr(":'{$", s[1])))
1035             break;
1036
1037         /* check for embedded scalars.  only stop if we're sure it's a
1038            variable.
1039         */
1040         else if (*s == '$') {
1041             if (!PL_lex_inpat)  /* not a regexp, so $ must be var */
1042                 break;
1043             if (s + 1 < send && !strchr("()| \n\t", s[1]))
1044                 break;          /* in regexp, $ might be tail anchor */
1045         }
1046
1047         /* (now in tr/// code again) */
1048
1049         if (*s & 0x80 && thisutf) {
1050             dTHR;                       /* only for ckWARN */
1051             if (ckWARN(WARN_UTF8)) {
1052                 (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */
1053                 if (len) {
1054                     while (len--)
1055                         *d++ = *s++;
1056                     continue;
1057                 }
1058             }
1059         }
1060
1061         /* backslashes */
1062         if (*s == '\\' && s+1 < send) {
1063             s++;
1064
1065             /* some backslashes we leave behind */
1066             if (*leaveit && *s && strchr(leaveit, *s)) {
1067                 *d++ = '\\';
1068                 *d++ = *s++;
1069                 continue;
1070             }
1071
1072             /* deprecate \1 in strings and substitution replacements */
1073             if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
1074                 isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
1075             {
1076                 dTHR;                   /* only for ckWARN */
1077                 if (ckWARN(WARN_SYNTAX))
1078                     warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
1079                 *--s = '$';
1080                 break;
1081             }
1082
1083             /* string-change backslash escapes */
1084             if (PL_lex_inwhat != OP_TRANS && *s && strchr("lLuUEQ", *s)) {
1085                 --s;
1086                 break;
1087             }
1088
1089             /* if we get here, it's either a quoted -, or a digit */
1090             switch (*s) {
1091
1092             /* quoted - in transliterations */
1093             case '-':
1094                 if (PL_lex_inwhat == OP_TRANS) {
1095                     *d++ = *s++;
1096                     continue;
1097                 }
1098                 /* FALL THROUGH */
1099             default:
1100                 {
1101                     dTHR;
1102                     if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
1103                         warner(WARN_UNSAFE,
1104                                "Unrecognized escape \\%c passed through",
1105                                *s);
1106                     /* default action is to copy the quoted character */
1107                     *d++ = *s++;
1108                     continue;
1109                 }
1110
1111             /* \132 indicates an octal constant */
1112             case '0': case '1': case '2': case '3':
1113             case '4': case '5': case '6': case '7':
1114                 *d++ = scan_oct(s, 3, &len);
1115                 s += len;
1116                 continue;
1117
1118             /* \x24 indicates a hex constant */
1119             case 'x':
1120                 ++s;
1121                 if (*s == '{') {
1122                     char* e = strchr(s, '}');
1123
1124                     if (!e) {
1125                         yyerror("Missing right brace on \\x{}");
1126                         e = s;
1127                     }
1128                     if (!utf) {
1129                         dTHR;
1130                         if (ckWARN(WARN_UTF8))
1131                             warner(WARN_UTF8,
1132                                    "Use of \\x{} without utf8 declaration");
1133                     }
1134                     /* note: utf always shorter than hex */
1135                     d = (char*)uv_to_utf8((U8*)d,
1136                                           scan_hex(s + 1, e - s - 1, &len));
1137                     s = e + 1;
1138
1139                 }
1140                 else {
1141                     UV uv = (UV)scan_hex(s, 2, &len);
1142                     if (utf && PL_lex_inwhat == OP_TRANS &&
1143                         utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF))
1144                     {
1145                         d = (char*)uv_to_utf8((U8*)d, uv);      /* doing a CU or UC */
1146                     }
1147                     else {
1148                         if (uv >= 127 && UTF) {
1149                             dTHR;
1150                             if (ckWARN(WARN_UTF8))
1151                                 warner(WARN_UTF8,
1152                                     "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
1153                                     len,s,len,s);
1154                         }
1155                         *d++ = (char)uv;
1156                     }
1157                     s += len;
1158                 }
1159                 continue;
1160
1161             /* \c is a control character */
1162             case 'c':
1163                 s++;
1164 #ifdef EBCDIC
1165                 *d = *s++;
1166                 if (isLOWER(*d))
1167                    *d = toUPPER(*d);
1168                 *d++ = toCTRL(*d);
1169 #else
1170                 len = *s++;
1171                 *d++ = toCTRL(len);
1172 #endif
1173                 continue;
1174
1175             /* printf-style backslashes, formfeeds, newlines, etc */
1176             case 'b':
1177                 *d++ = '\b';
1178                 break;
1179             case 'n':
1180                 *d++ = '\n';
1181                 break;
1182             case 'r':
1183                 *d++ = '\r';
1184                 break;
1185             case 'f':
1186                 *d++ = '\f';
1187                 break;
1188             case 't':
1189                 *d++ = '\t';
1190                 break;
1191             case 'e':
1192                 *d++ = '\033';
1193                 break;
1194             case 'a':
1195                 *d++ = '\007';
1196                 break;
1197             } /* end switch */
1198
1199             s++;
1200             continue;
1201         } /* end if (backslash) */
1202
1203         *d++ = *s++;
1204     } /* while loop to process each character */
1205
1206     /* terminate the string and set up the sv */
1207     *d = '\0';
1208     SvCUR_set(sv, d - SvPVX(sv));
1209     SvPOK_on(sv);
1210
1211     /* shrink the sv if we allocated more than we used */
1212     if (SvCUR(sv) + 5 < SvLEN(sv)) {
1213         SvLEN_set(sv, SvCUR(sv) + 1);
1214         Renew(SvPVX(sv), SvLEN(sv), char);
1215     }
1216
1217     /* return the substring (via yylval) only if we parsed anything */
1218     if (s > PL_bufptr) {
1219         if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) )
1220             sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"),
1221                               sv, Nullsv,
1222                               ( PL_lex_inwhat == OP_TRANS
1223                                 ? "tr"
1224                                 : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat)
1225                                     ? "s"
1226                                     : "qq")));
1227         yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1228     } else
1229         SvREFCNT_dec(sv);
1230     return s;
1231 }
1232
1233 /* This is the one truly awful dwimmer necessary to conflate C and sed. */
1234 STATIC int
1235 intuit_more(register char *s)
1236 {
1237     if (PL_lex_brackets)
1238         return TRUE;
1239     if (*s == '-' && s[1] == '>' && (s[2] == '[' || s[2] == '{'))
1240         return TRUE;
1241     if (*s != '{' && *s != '[')
1242         return FALSE;
1243     if (!PL_lex_inpat)
1244         return TRUE;
1245
1246     /* In a pattern, so maybe we have {n,m}. */
1247     if (*s == '{') {
1248         s++;
1249         if (!isDIGIT(*s))
1250             return TRUE;
1251         while (isDIGIT(*s))
1252             s++;
1253         if (*s == ',')
1254             s++;
1255         while (isDIGIT(*s))
1256             s++;
1257         if (*s == '}')
1258             return FALSE;
1259         return TRUE;
1260
1261     }
1262
1263     /* On the other hand, maybe we have a character class */
1264
1265     s++;
1266     if (*s == ']' || *s == '^')
1267         return FALSE;
1268     else {
1269         int weight = 2;         /* let's weigh the evidence */
1270         char seen[256];
1271         unsigned char un_char = 255, last_un_char;
1272         char *send = strchr(s,']');
1273         char tmpbuf[sizeof PL_tokenbuf * 4];
1274
1275         if (!send)              /* has to be an expression */
1276             return TRUE;
1277
1278         Zero(seen,256,char);
1279         if (*s == '$')
1280             weight -= 3;
1281         else if (isDIGIT(*s)) {
1282             if (s[1] != ']') {
1283                 if (isDIGIT(s[1]) && s[2] == ']')
1284                     weight -= 10;
1285             }
1286             else
1287                 weight -= 100;
1288         }
1289         for (; s < send; s++) {
1290             last_un_char = un_char;
1291             un_char = (unsigned char)*s;
1292             switch (*s) {
1293             case '@':
1294             case '&':
1295             case '$':
1296                 weight -= seen[un_char] * 10;
1297                 if (isALNUM_lazy(s+1)) {
1298                     scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE);
1299                     if ((int)strlen(tmpbuf) > 1 && gv_fetchpv(tmpbuf,FALSE, SVt_PV))
1300                         weight -= 100;
1301                     else
1302                         weight -= 10;
1303                 }
1304                 else if (*s == '$' && s[1] &&
1305                   strchr("[#!%*<>()-=",s[1])) {
1306                     if (/*{*/ strchr("])} =",s[2]))
1307                         weight -= 10;
1308                     else
1309                         weight -= 1;
1310                 }
1311                 break;
1312             case '\\':
1313                 un_char = 254;
1314                 if (s[1]) {
1315                     if (strchr("wds]",s[1]))
1316                         weight += 100;
1317                     else if (seen['\''] || seen['"'])
1318                         weight += 1;
1319                     else if (strchr("rnftbxcav",s[1]))
1320                         weight += 40;
1321                     else if (isDIGIT(s[1])) {
1322                         weight += 40;
1323                         while (s[1] && isDIGIT(s[1]))
1324                             s++;
1325                     }
1326                 }
1327                 else
1328                     weight += 100;
1329                 break;
1330             case '-':
1331                 if (s[1] == '\\')
1332                     weight += 50;
1333                 if (strchr("aA01! ",last_un_char))
1334                     weight += 30;
1335                 if (strchr("zZ79~",s[1]))
1336                     weight += 30;
1337                 if (last_un_char == 255 && (isDIGIT(s[1]) || s[1] == '$'))
1338                     weight -= 5;        /* cope with negative subscript */
1339                 break;
1340             default:
1341                 if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) &&
1342                         isALPHA(*s) && s[1] && isALPHA(s[1])) {
1343                     char *d = tmpbuf;
1344                     while (isALPHA(*s))
1345                         *d++ = *s++;
1346                     *d = '\0';
1347                     if (keyword(tmpbuf, d - tmpbuf))
1348                         weight -= 150;
1349                 }
1350                 if (un_char == last_un_char + 1)
1351                     weight += 5;
1352                 weight -= seen[un_char];
1353                 break;
1354             }
1355             seen[un_char]++;
1356         }
1357         if (weight >= 0)        /* probably a character class */
1358             return FALSE;
1359     }
1360
1361     return TRUE;
1362 }
1363
1364 STATIC int
1365 intuit_method(char *start, GV *gv)
1366 {
1367     char *s = start + (*start == '$');
1368     char tmpbuf[sizeof PL_tokenbuf];
1369     STRLEN len;
1370     GV* indirgv;
1371
1372     if (gv) {
1373         CV *cv;
1374         if (GvIO(gv))
1375             return 0;
1376         if ((cv = GvCVu(gv))) {
1377             char *proto = SvPVX(cv);
1378             if (proto) {
1379                 if (*proto == ';')
1380                     proto++;
1381                 if (*proto == '*')
1382                     return 0;
1383             }
1384         } else
1385             gv = 0;
1386     }
1387     s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
1388     if (*start == '$') {
1389         if (gv || PL_last_lop_op == OP_PRINT || isUPPER(*PL_tokenbuf))
1390             return 0;
1391         s = skipspace(s);
1392         PL_bufptr = start;
1393         PL_expect = XREF;
1394         return *s == '(' ? FUNCMETH : METHOD;
1395     }
1396     if (!keyword(tmpbuf, len)) {
1397         if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') {
1398             len -= 2;
1399             tmpbuf[len] = '\0';
1400             goto bare_package;
1401         }
1402         indirgv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
1403         if (indirgv && GvCVu(indirgv))
1404             return 0;
1405         /* filehandle or package name makes it a method */
1406         if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) {
1407             s = skipspace(s);
1408             if ((PL_bufend - s) >= 2 && *s == '=' && *(s+1) == '>')
1409                 return 0;       /* no assumptions -- "=>" quotes bearword */
1410       bare_package:
1411             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0,
1412                                                    newSVpv(tmpbuf,0));
1413             PL_nextval[PL_nexttoke].opval->op_private = OPpCONST_BARE;
1414             PL_expect = XTERM;
1415             force_next(WORD);
1416             PL_bufptr = s;
1417             return *s == '(' ? FUNCMETH : METHOD;
1418         }
1419     }
1420     return 0;
1421 }
1422
1423 STATIC char*
1424 incl_perldb(void)
1425 {
1426     if (PL_perldb) {
1427         char *pdb = PerlEnv_getenv("PERL5DB");
1428
1429         if (pdb)
1430             return pdb;
1431         SETERRNO(0,SS$_NORMAL);
1432         return "BEGIN { require 'perl5db.pl' }";
1433     }
1434     return "";
1435 }
1436
1437
1438 /* Encoded script support. filter_add() effectively inserts a
1439  * 'pre-processing' function into the current source input stream.
1440  * Note that the filter function only applies to the current source file
1441  * (e.g., it will not affect files 'require'd or 'use'd by this one).
1442  *
1443  * The datasv parameter (which may be NULL) can be used to pass
1444  * private data to this instance of the filter. The filter function
1445  * can recover the SV using the FILTER_DATA macro and use it to
1446  * store private buffers and state information.
1447  *
1448  * The supplied datasv parameter is upgraded to a PVIO type
1449  * and the IoDIRP field is used to store the function pointer.
1450  * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for
1451  * private use must be set using malloc'd pointers.
1452  */
1453 static int filter_debug = 0;
1454
1455 SV *
1456 filter_add(filter_t funcp, SV *datasv)
1457 {
1458     if (!funcp){ /* temporary handy debugging hack to be deleted */
1459         filter_debug = atoi((char*)datasv);
1460         return NULL;
1461     }
1462     if (!PL_rsfp_filters)
1463         PL_rsfp_filters = newAV();
1464     if (!datasv)
1465         datasv = NEWSV(255,0);
1466     if (!SvUPGRADE(datasv, SVt_PVIO))
1467         die("Can't upgrade filter_add data to SVt_PVIO");
1468     IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */
1469     if (filter_debug) {
1470         STRLEN n_a;
1471         warn("filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
1472     }
1473     av_unshift(PL_rsfp_filters, 1);
1474     av_store(PL_rsfp_filters, 0, datasv) ;
1475     return(datasv);
1476 }
1477
1478
1479 /* Delete most recently added instance of this filter function. */
1480 void
1481 filter_del(filter_t funcp)
1482 {
1483     if (filter_debug)
1484         warn("filter_del func %p", funcp);
1485     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
1486         return;
1487     /* if filter is on top of stack (usual case) just pop it off */
1488     if (IoDIRP(FILTER_DATA(AvFILLp(PL_rsfp_filters))) == (DIR*)funcp){
1489         sv_free(av_pop(PL_rsfp_filters));
1490
1491         return;
1492     }
1493     /* we need to search for the correct entry and clear it     */
1494     die("filter_del can only delete in reverse order (currently)");
1495 }
1496
1497
1498 /* Invoke the n'th filter function for the current rsfp.         */
1499 I32
1500 filter_read(int idx, SV *buf_sv, int maxlen)
1501
1502
1503                         /* 0 = read one text line */
1504 {
1505     filter_t funcp;
1506     SV *datasv = NULL;
1507
1508     if (!PL_rsfp_filters)
1509         return -1;
1510     if (idx > AvFILLp(PL_rsfp_filters)){       /* Any more filters?     */
1511         /* Provide a default input filter to make life easy.    */
1512         /* Note that we append to the line. This is handy.      */
1513         if (filter_debug)
1514             warn("filter_read %d: from rsfp\n", idx);
1515         if (maxlen) {
1516             /* Want a block */
1517             int len ;
1518             int old_len = SvCUR(buf_sv) ;
1519
1520             /* ensure buf_sv is large enough */
1521             SvGROW(buf_sv, old_len + maxlen) ;
1522             if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){
1523                 if (PerlIO_error(PL_rsfp))
1524                     return -1;          /* error */
1525                 else
1526                     return 0 ;          /* end of file */
1527             }
1528             SvCUR_set(buf_sv, old_len + len) ;
1529         } else {
1530             /* Want a line */
1531             if (sv_gets(buf_sv, PL_rsfp, SvCUR(buf_sv)) == NULL) {
1532                 if (PerlIO_error(PL_rsfp))
1533                     return -1;          /* error */
1534                 else
1535                     return 0 ;          /* end of file */
1536             }
1537         }
1538         return SvCUR(buf_sv);
1539     }
1540     /* Skip this filter slot if filter has been deleted */
1541     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
1542         if (filter_debug)
1543             warn("filter_read %d: skipped (filter deleted)\n", idx);
1544         return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */
1545     }
1546     /* Get function pointer hidden within datasv        */
1547     funcp = (filter_t)IoDIRP(datasv);
1548     if (filter_debug) {
1549         STRLEN n_a;
1550         warn("filter_read %d: via function %p (%s)\n",
1551                 idx, funcp, SvPV(datasv,n_a));
1552     }
1553     /* Call function. The function is expected to       */
1554     /* call "FILTER_READ(idx+1, buf_sv)" first.         */
1555     /* Return: <0:error, =0:eof, >0:not eof             */
1556     return (*funcp)(PERL_OBJECT_THIS_ idx, buf_sv, maxlen);
1557 }
1558
1559 STATIC char *
1560 filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
1561 {
1562 #ifdef WIN32FILTER
1563     if (!PL_rsfp_filters) {
1564         filter_add(win32_textfilter,NULL);
1565     }
1566 #endif
1567     if (PL_rsfp_filters) {
1568
1569         if (!append)
1570             SvCUR_set(sv, 0);   /* start with empty line        */
1571         if (FILTER_READ(0, sv, 0) > 0)
1572             return ( SvPVX(sv) ) ;
1573         else
1574             return Nullch ;
1575     }
1576     else
1577         return (sv_gets(sv, fp, append));
1578 }
1579
1580
1581 #ifdef DEBUGGING
1582     static char* exp_name[] =
1583         { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" };
1584 #endif
1585
1586 /*
1587   yylex
1588
1589   Works out what to call the token just pulled out of the input
1590   stream.  The yacc parser takes care of taking the ops we return and
1591   stitching them into a tree.
1592
1593   Returns:
1594     PRIVATEREF
1595
1596   Structure:
1597       if read an identifier
1598           if we're in a my declaration
1599               croak if they tried to say my($foo::bar)
1600               build the ops for a my() declaration
1601           if it's an access to a my() variable
1602               are we in a sort block?
1603                   croak if my($a); $a <=> $b
1604               build ops for access to a my() variable
1605           if in a dq string, and they've said @foo and we can't find @foo
1606               croak
1607           build ops for a bareword
1608       if we already built the token before, use it.
1609 */
1610
1611 int yylex(PERL_YYLEX_PARAM_DECL)
1612 {
1613     dTHR;
1614     register char *s;
1615     register char *d;
1616     register I32 tmp;
1617     STRLEN len;
1618     GV *gv = Nullgv;
1619     GV **gvp = 0;
1620
1621 #ifdef USE_PURE_BISON
1622     yylval_pointer = lvalp;
1623     yychar_pointer = lcharp;
1624 #endif
1625
1626     /* check if there's an identifier for us to look at */
1627     if (PL_pending_ident) {
1628         /* pit holds the identifier we read and pending_ident is reset */
1629         char pit = PL_pending_ident;
1630         PL_pending_ident = 0;
1631
1632         /* if we're in a my(), we can't allow dynamics here.
1633            $foo'bar has already been turned into $foo::bar, so
1634            just check for colons.
1635
1636            if it's a legal name, the OP is a PADANY.
1637         */
1638         if (PL_in_my) {
1639             if (strchr(PL_tokenbuf,':'))
1640                 croak(PL_no_myglob,PL_tokenbuf);
1641
1642             yylval.opval = newOP(OP_PADANY, 0);
1643             yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
1644             return PRIVATEREF;
1645         }
1646
1647         /*
1648            build the ops for accesses to a my() variable.
1649
1650            Deny my($a) or my($b) in a sort block, *if* $a or $b is
1651            then used in a comparison.  This catches most, but not
1652            all cases.  For instance, it catches
1653                sort { my($a); $a <=> $b }
1654            but not
1655                sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; }
1656            (although why you'd do that is anyone's guess).
1657         */
1658
1659         if (!strchr(PL_tokenbuf,':')) {
1660 #ifdef USE_THREADS
1661             /* Check for single character per-thread SVs */
1662             if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0'
1663                 && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */
1664                 && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD)
1665             {
1666                 yylval.opval = newOP(OP_THREADSV, 0);
1667                 yylval.opval->op_targ = tmp;
1668                 return PRIVATEREF;
1669             }
1670 #endif /* USE_THREADS */
1671             if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) {
1672                 /* if it's a sort block and they're naming $a or $b */
1673                 if (PL_last_lop_op == OP_SORT &&
1674                     PL_tokenbuf[0] == '$' &&
1675                     (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b')
1676                     && !PL_tokenbuf[2])
1677                 {
1678                     for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart;
1679                          d < PL_bufend && *d != '\n';
1680                          d++)
1681                     {
1682                         if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
1683                             croak("Can't use \"my %s\" in sort comparison",
1684                                   PL_tokenbuf);
1685                         }
1686                     }
1687                 }
1688
1689                 yylval.opval = newOP(OP_PADANY, 0);
1690                 yylval.opval->op_targ = tmp;
1691                 return PRIVATEREF;
1692             }
1693         }
1694
1695         /*
1696            Whine if they've said @foo in a doublequoted string,
1697            and @foo isn't a variable we can find in the symbol
1698            table.
1699         */
1700         if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) {
1701             GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV);
1702             if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv)))
1703                 yyerror(form("In string, %s now must be written as \\%s",
1704                              PL_tokenbuf, PL_tokenbuf));
1705         }
1706
1707         /* build ops for a bareword */
1708         yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0));
1709         yylval.opval->op_private = OPpCONST_ENTERED;
1710         gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE,
1711                    ((PL_tokenbuf[0] == '$') ? SVt_PV
1712                     : (PL_tokenbuf[0] == '@') ? SVt_PVAV
1713                     : SVt_PVHV));
1714         return WORD;
1715     }
1716
1717     /* no identifier pending identification */
1718
1719     switch (PL_lex_state) {
1720 #ifdef COMMENTARY
1721     case LEX_NORMAL:            /* Some compilers will produce faster */
1722     case LEX_INTERPNORMAL:      /* code if we comment these out. */
1723         break;
1724 #endif
1725
1726     /* when we're already built the next token, just pull it out the queue */
1727     case LEX_KNOWNEXT:
1728         PL_nexttoke--;
1729         yylval = PL_nextval[PL_nexttoke];
1730         if (!PL_nexttoke) {
1731             PL_lex_state = PL_lex_defer;
1732             PL_expect = PL_lex_expect;
1733             PL_lex_defer = LEX_NORMAL;
1734         }
1735         return(PL_nexttype[PL_nexttoke]);
1736
1737     /* interpolated case modifiers like \L \U, including \Q and \E.
1738        when we get here, PL_bufptr is at the \
1739     */
1740     case LEX_INTERPCASEMOD:
1741 #ifdef DEBUGGING
1742         if (PL_bufptr != PL_bufend && *PL_bufptr != '\\')
1743             croak("panic: INTERPCASEMOD");
1744 #endif
1745         /* handle \E or end of string */
1746         if (PL_bufptr == PL_bufend || PL_bufptr[1] == 'E') {
1747             char oldmod;
1748
1749             /* if at a \E */
1750             if (PL_lex_casemods) {
1751                 oldmod = PL_lex_casestack[--PL_lex_casemods];
1752                 PL_lex_casestack[PL_lex_casemods] = '\0';
1753
1754                 if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) {
1755                     PL_bufptr += 2;
1756                     PL_lex_state = LEX_INTERPCONCAT;
1757                 }
1758                 return ')';
1759             }
1760             if (PL_bufptr != PL_bufend)
1761                 PL_bufptr += 2;
1762             PL_lex_state = LEX_INTERPCONCAT;
1763             return yylex(PERL_YYLEX_PARAM);
1764         }
1765         else {
1766             s = PL_bufptr + 1;
1767             if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3))
1768                 tmp = *s, *s = s[2], s[2] = tmp;        /* misordered... */
1769             if (strchr("LU", *s) &&
1770                 (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U')))
1771             {
1772                 PL_lex_casestack[--PL_lex_casemods] = '\0';
1773                 return ')';
1774             }
1775             if (PL_lex_casemods > 10) {
1776                 char* newlb = Renew(PL_lex_casestack, PL_lex_casemods + 2, char);
1777                 if (newlb != PL_lex_casestack) {
1778                     SAVEFREEPV(newlb);
1779                     PL_lex_casestack = newlb;
1780                 }
1781             }
1782             PL_lex_casestack[PL_lex_casemods++] = *s;
1783             PL_lex_casestack[PL_lex_casemods] = '\0';
1784             PL_lex_state = LEX_INTERPCONCAT;
1785             PL_nextval[PL_nexttoke].ival = 0;
1786             force_next('(');
1787             if (*s == 'l')
1788                 PL_nextval[PL_nexttoke].ival = OP_LCFIRST;
1789             else if (*s == 'u')
1790                 PL_nextval[PL_nexttoke].ival = OP_UCFIRST;
1791             else if (*s == 'L')
1792                 PL_nextval[PL_nexttoke].ival = OP_LC;
1793             else if (*s == 'U')
1794                 PL_nextval[PL_nexttoke].ival = OP_UC;
1795             else if (*s == 'Q')
1796                 PL_nextval[PL_nexttoke].ival = OP_QUOTEMETA;
1797             else
1798                 croak("panic: yylex");
1799             PL_bufptr = s + 1;
1800             force_next(FUNC);
1801             if (PL_lex_starts) {
1802                 s = PL_bufptr;
1803                 PL_lex_starts = 0;
1804                 Aop(OP_CONCAT);
1805             }
1806             else
1807                 return yylex(PERL_YYLEX_PARAM);
1808         }
1809
1810     case LEX_INTERPPUSH:
1811         return sublex_push();
1812
1813     case LEX_INTERPSTART:
1814         if (PL_bufptr == PL_bufend)
1815             return sublex_done();
1816         PL_expect = XTERM;
1817         PL_lex_dojoin = (*PL_bufptr == '@');
1818         PL_lex_state = LEX_INTERPNORMAL;
1819         if (PL_lex_dojoin) {
1820             PL_nextval[PL_nexttoke].ival = 0;
1821             force_next(',');
1822 #ifdef USE_THREADS
1823             PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0);
1824             PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\"");
1825             force_next(PRIVATEREF);
1826 #else
1827             force_ident("\"", '$');
1828 #endif /* USE_THREADS */
1829             PL_nextval[PL_nexttoke].ival = 0;
1830             force_next('$');
1831             PL_nextval[PL_nexttoke].ival = 0;
1832             force_next('(');
1833             PL_nextval[PL_nexttoke].ival = OP_JOIN;     /* emulate join($", ...) */
1834             force_next(FUNC);
1835         }
1836         if (PL_lex_starts++) {
1837             s = PL_bufptr;
1838             Aop(OP_CONCAT);
1839         }
1840         return yylex(PERL_YYLEX_PARAM);
1841
1842     case LEX_INTERPENDMAYBE:
1843         if (intuit_more(PL_bufptr)) {
1844             PL_lex_state = LEX_INTERPNORMAL;    /* false alarm, more expr */
1845             break;
1846         }
1847         /* FALL THROUGH */
1848
1849     case LEX_INTERPEND:
1850         if (PL_lex_dojoin) {
1851             PL_lex_dojoin = FALSE;
1852             PL_lex_state = LEX_INTERPCONCAT;
1853             return ')';
1854         }
1855         if (PL_lex_inwhat == OP_SUBST && PL_lex_repl && SvCOMPILED(PL_lex_repl)) {
1856             if (PL_bufptr != PL_bufend)
1857                 croak("Bad evalled substitution pattern");
1858             PL_lex_repl = Nullsv;
1859         }
1860         /* FALLTHROUGH */
1861     case LEX_INTERPCONCAT:
1862 #ifdef DEBUGGING
1863         if (PL_lex_brackets)
1864             croak("panic: INTERPCONCAT");
1865 #endif
1866         if (PL_bufptr == PL_bufend)
1867             return sublex_done();
1868
1869         if (SvIVX(PL_linestr) == '\'') {
1870             SV *sv = newSVsv(PL_linestr);
1871             if (!PL_lex_inpat)
1872                 sv = tokeq(sv);
1873             else if ( PL_hints & HINT_NEW_RE )
1874                 sv = new_constant(NULL, 0, "qr", sv, sv, "q");
1875             yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
1876             s = PL_bufend;
1877         }
1878         else {
1879             s = scan_const(PL_bufptr);
1880             if (*s == '\\')
1881                 PL_lex_state = LEX_INTERPCASEMOD;
1882             else
1883                 PL_lex_state = LEX_INTERPSTART;
1884         }
1885
1886         if (s != PL_bufptr) {
1887             PL_nextval[PL_nexttoke] = yylval;
1888             PL_expect = XTERM;
1889             force_next(THING);
1890             if (PL_lex_starts++)
1891                 Aop(OP_CONCAT);
1892             else {
1893                 PL_bufptr = s;
1894                 return yylex(PERL_YYLEX_PARAM);
1895             }
1896         }
1897
1898         return yylex(PERL_YYLEX_PARAM);
1899     case LEX_FORMLINE:
1900         PL_lex_state = LEX_NORMAL;
1901         s = scan_formline(PL_bufptr);
1902         if (!PL_lex_formbrack)
1903             goto rightbracket;
1904         OPERATOR(';');
1905     }
1906
1907     s = PL_bufptr;
1908     PL_oldoldbufptr = PL_oldbufptr;
1909     PL_oldbufptr = s;
1910     DEBUG_p( {
1911         PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[PL_expect], s);
1912     } )
1913
1914   retry:
1915     switch (*s) {
1916     default:
1917         if (isIDFIRST_lazy(s))
1918             goto keylookup;
1919         croak("Unrecognized character \\x%02X", *s & 255);
1920     case 4:
1921     case 26:
1922         goto fake_eof;                  /* emulate EOF on ^D or ^Z */
1923     case 0:
1924         if (!PL_rsfp) {
1925             PL_last_uni = 0;
1926             PL_last_lop = 0;
1927             if (PL_lex_brackets)
1928                 yyerror("Missing right bracket");
1929             TOKEN(0);
1930         }
1931         if (s++ < PL_bufend)
1932             goto retry;                 /* ignore stray nulls */
1933         PL_last_uni = 0;
1934         PL_last_lop = 0;
1935         if (!PL_in_eval && !PL_preambled) {
1936             PL_preambled = TRUE;
1937             sv_setpv(PL_linestr,incl_perldb());
1938             if (SvCUR(PL_linestr))
1939                 sv_catpv(PL_linestr,";");
1940             if (PL_preambleav){
1941                 while(AvFILLp(PL_preambleav) >= 0) {
1942                     SV *tmpsv = av_shift(PL_preambleav);
1943                     sv_catsv(PL_linestr, tmpsv);
1944                     sv_catpv(PL_linestr, ";");
1945                     sv_free(tmpsv);
1946                 }
1947                 sv_free((SV*)PL_preambleav);
1948                 PL_preambleav = NULL;
1949             }
1950             if (PL_minus_n || PL_minus_p) {
1951                 sv_catpv(PL_linestr, "LINE: while (<>) {");
1952                 if (PL_minus_l)
1953                     sv_catpv(PL_linestr,"chomp;");
1954                 if (PL_minus_a) {
1955                     GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV);
1956                     if (gv)
1957                         GvIMPORTED_AV_on(gv);
1958                     if (PL_minus_F) {
1959                         if (strchr("/'\"", *PL_splitstr)
1960                               && strchr(PL_splitstr + 1, *PL_splitstr))
1961                             sv_catpvf(PL_linestr, "@F=split(%s);", PL_splitstr);
1962                         else {
1963                             char delim;
1964                             s = "'~#\200\1'"; /* surely one char is unused...*/
1965                             while (s[1] && strchr(PL_splitstr, *s))  s++;
1966                             delim = *s;
1967                             sv_catpvf(PL_linestr, "@F=split(%s%c",
1968                                       "q" + (delim == '\''), delim);
1969                             for (s = PL_splitstr; *s; s++) {
1970                                 if (*s == '\\')
1971                                     sv_catpvn(PL_linestr, "\\", 1);
1972                                 sv_catpvn(PL_linestr, s, 1);
1973                             }
1974                             sv_catpvf(PL_linestr, "%c);", delim);
1975                         }
1976                     }
1977                     else
1978                         sv_catpv(PL_linestr,"@F=split(' ');");
1979                 }
1980             }
1981             sv_catpv(PL_linestr, "\n");
1982             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
1983             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
1984             if (PERLDB_LINE && PL_curstash != PL_debstash) {
1985                 SV *sv = NEWSV(85,0);
1986
1987                 sv_upgrade(sv, SVt_PVMG);
1988                 sv_setsv(sv,PL_linestr);
1989                 av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
1990             }
1991             goto retry;
1992         }
1993         do {
1994             if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
1995               fake_eof:
1996                 if (PL_rsfp) {
1997                     if (PL_preprocess && !PL_in_eval)
1998                         (void)PerlProc_pclose(PL_rsfp);
1999                     else if ((PerlIO *)PL_rsfp == PerlIO_stdin())
2000                         PerlIO_clearerr(PL_rsfp);
2001                     else
2002                         (void)PerlIO_close(PL_rsfp);
2003                     PL_rsfp = Nullfp;
2004                     PL_doextract = FALSE;
2005                 }
2006                 if (!PL_in_eval && (PL_minus_n || PL_minus_p)) {
2007                     sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : "");
2008                     sv_catpv(PL_linestr,";}");
2009                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2010                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2011                     PL_minus_n = PL_minus_p = 0;
2012                     goto retry;
2013                 }
2014                 PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2015                 sv_setpv(PL_linestr,"");
2016                 TOKEN(';');     /* not infinite loop because rsfp is NULL now */
2017             }
2018             if (PL_doextract) {
2019                 if (*s == '#' && s[1] == '!' && instr(s,"perl"))
2020                     PL_doextract = FALSE;
2021
2022                 /* Incest with pod. */
2023                 if (*s == '=' && strnEQ(s, "=cut", 4)) {
2024                     sv_setpv(PL_linestr, "");
2025                     PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2026                     PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2027                     PL_doextract = FALSE;
2028                 }
2029             }
2030             incline(s);
2031         } while (PL_doextract);
2032         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
2033         if (PERLDB_LINE && PL_curstash != PL_debstash) {
2034             SV *sv = NEWSV(85,0);
2035
2036             sv_upgrade(sv, SVt_PVMG);
2037             sv_setsv(sv,PL_linestr);
2038             av_store(GvAV(PL_curcop->cop_filegv),(I32)PL_curcop->cop_line,sv);
2039         }
2040         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2041         if (PL_curcop->cop_line == 1) {
2042             while (s < PL_bufend && isSPACE(*s))
2043                 s++;
2044             if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */
2045                 s++;
2046             d = Nullch;
2047             if (!PL_in_eval) {
2048                 if (*s == '#' && *(s+1) == '!')
2049                     d = s + 2;
2050 #ifdef ALTERNATE_SHEBANG
2051                 else {
2052                     static char as[] = ALTERNATE_SHEBANG;
2053                     if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1))
2054                         d = s + (sizeof(as) - 1);
2055                 }
2056 #endif /* ALTERNATE_SHEBANG */
2057             }
2058             if (d) {
2059                 char *ipath;
2060                 char *ipathend;
2061
2062                 while (isSPACE(*d))
2063                     d++;
2064                 ipath = d;
2065                 while (*d && !isSPACE(*d))
2066                     d++;
2067                 ipathend = d;
2068
2069 #ifdef ARG_ZERO_IS_SCRIPT
2070                 if (ipathend > ipath) {
2071                     /*
2072                      * HP-UX (at least) sets argv[0] to the script name,
2073                      * which makes $^X incorrect.  And Digital UNIX and Linux,
2074                      * at least, set argv[0] to the basename of the Perl
2075                      * interpreter. So, having found "#!", we'll set it right.
2076                      */
2077                     SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV));
2078                     assert(SvPOK(x) || SvGMAGICAL(x));
2079                     if (sv_eq(x, GvSV(PL_curcop->cop_filegv))) {
2080                         sv_setpvn(x, ipath, ipathend - ipath);
2081                         SvSETMAGIC(x);
2082                     }
2083                     TAINT_NOT;  /* $^X is always tainted, but that's OK */
2084                 }
2085 #endif /* ARG_ZERO_IS_SCRIPT */
2086
2087                 /*
2088                  * Look for options.
2089                  */
2090                 d = instr(s,"perl -");
2091                 if (!d)
2092                     d = instr(s,"perl");
2093 #ifdef ALTERNATE_SHEBANG
2094                 /*
2095                  * If the ALTERNATE_SHEBANG on this system starts with a
2096                  * character that can be part of a Perl expression, then if
2097                  * we see it but not "perl", we're probably looking at the
2098                  * start of Perl code, not a request to hand off to some
2099                  * other interpreter.  Similarly, if "perl" is there, but
2100                  * not in the first 'word' of the line, we assume the line
2101                  * contains the start of the Perl program.
2102                  */
2103                 if (d && *s != '#') {
2104                     char *c = ipath;
2105                     while (*c && !strchr("; \t\r\n\f\v#", *c))
2106                         c++;
2107                     if (c < d)
2108                         d = Nullch;     /* "perl" not in first word; ignore */
2109                     else
2110                         *s = '#';       /* Don't try to parse shebang line */
2111                 }
2112 #endif /* ALTERNATE_SHEBANG */
2113                 if (!d &&
2114                     *s == '#' &&
2115                     ipathend > ipath &&
2116                     !PL_minus_c &&
2117                     !instr(s,"indir") &&
2118                     instr(PL_origargv[0],"perl"))
2119                 {
2120                     char **newargv;
2121
2122                     *ipathend = '\0';
2123                     s = ipathend + 1;
2124                     while (s < PL_bufend && isSPACE(*s))
2125                         s++;
2126                     if (s < PL_bufend) {
2127                         Newz(899,newargv,PL_origargc+3,char*);
2128                         newargv[1] = s;
2129                         while (s < PL_bufend && !isSPACE(*s))
2130                             s++;
2131                         *s = '\0';
2132                         Copy(PL_origargv+1, newargv+2, PL_origargc+1, char*);
2133                     }
2134                     else
2135                         newargv = PL_origargv;
2136                     newargv[0] = ipath;
2137                     execv(ipath, newargv);
2138                     croak("Can't exec %s", ipath);
2139                 }
2140                 if (d) {
2141                     U32 oldpdb = PL_perldb;
2142                     bool oldn = PL_minus_n;
2143                     bool oldp = PL_minus_p;
2144
2145                     while (*d && !isSPACE(*d)) d++;
2146                     while (*d == ' ' || *d == '\t') d++;
2147
2148                     if (*d++ == '-') {
2149                         do {
2150                             if (*d == 'M' || *d == 'm') {
2151                                 char *m = d;
2152                                 while (*d && !isSPACE(*d)) d++;
2153                                 croak("Too late for \"-%.*s\" option",
2154                                       (int)(d - m), m);
2155                             }
2156                             d = moreswitches(d);
2157                         } while (d);
2158                         if (PERLDB_LINE && !oldpdb ||
2159                             ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) )
2160                               /* if we have already added "LINE: while (<>) {",
2161                                  we must not do it again */
2162                         {
2163                             sv_setpv(PL_linestr, "");
2164                             PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
2165                             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
2166                             PL_preambled = FALSE;
2167                             if (PERLDB_LINE)
2168                                 (void)gv_fetchfile(PL_origfilename);
2169                             goto retry;
2170                         }
2171                     }
2172                 }
2173             }
2174         }
2175         if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2176             PL_bufptr = s;
2177             PL_lex_state = LEX_FORMLINE;
2178             return yylex(PERL_YYLEX_PARAM);
2179         }
2180         goto retry;
2181     case '\r':
2182 #ifdef PERL_STRICT_CR
2183         warn("Illegal character \\%03o (carriage return)", '\r');
2184         croak(
2185       "(Maybe you didn't strip carriage returns after a network transfer?)\n");
2186 #endif
2187     case ' ': case '\t': case '\f': case 013:
2188         s++;
2189         goto retry;
2190     case '#':
2191     case '\n':
2192         if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
2193             d = PL_bufend;
2194             while (s < d && *s != '\n')
2195                 s++;
2196             if (s < d)
2197                 s++;
2198             incline(s);
2199             if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
2200                 PL_bufptr = s;
2201                 PL_lex_state = LEX_FORMLINE;
2202                 return yylex(PERL_YYLEX_PARAM);
2203             }
2204         }
2205         else {
2206             *s = '\0';
2207             PL_bufend = s;
2208         }
2209         goto retry;
2210     case '-':
2211         if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) {
2212             s++;
2213             PL_bufptr = s;
2214             tmp = *s++;
2215
2216             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2217                 s++;
2218
2219             if (strnEQ(s,"=>",2)) {
2220                 s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
2221                 OPERATOR('-');          /* unary minus */
2222             }
2223             PL_last_uni = PL_oldbufptr;
2224             PL_last_lop_op = OP_FTEREAD;        /* good enough */
2225             switch (tmp) {
2226             case 'r': FTST(OP_FTEREAD);
2227             case 'w': FTST(OP_FTEWRITE);
2228             case 'x': FTST(OP_FTEEXEC);
2229             case 'o': FTST(OP_FTEOWNED);
2230             case 'R': FTST(OP_FTRREAD);
2231             case 'W': FTST(OP_FTRWRITE);
2232             case 'X': FTST(OP_FTREXEC);
2233             case 'O': FTST(OP_FTROWNED);
2234             case 'e': FTST(OP_FTIS);
2235             case 'z': FTST(OP_FTZERO);
2236             case 's': FTST(OP_FTSIZE);
2237             case 'f': FTST(OP_FTFILE);
2238             case 'd': FTST(OP_FTDIR);
2239             case 'l': FTST(OP_FTLINK);
2240             case 'p': FTST(OP_FTPIPE);
2241             case 'S': FTST(OP_FTSOCK);
2242             case 'u': FTST(OP_FTSUID);
2243             case 'g': FTST(OP_FTSGID);
2244             case 'k': FTST(OP_FTSVTX);
2245             case 'b': FTST(OP_FTBLK);
2246             case 'c': FTST(OP_FTCHR);
2247             case 't': FTST(OP_FTTTY);
2248             case 'T': FTST(OP_FTTEXT);
2249             case 'B': FTST(OP_FTBINARY);
2250             case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME);
2251             case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME);
2252             case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME);
2253             default:
2254                 croak("Unrecognized file test: -%c", (int)tmp);
2255                 break;
2256             }
2257         }
2258         tmp = *s++;
2259         if (*s == tmp) {
2260             s++;
2261             if (PL_expect == XOPERATOR)
2262                 TERM(POSTDEC);
2263             else
2264                 OPERATOR(PREDEC);
2265         }
2266         else if (*s == '>') {
2267             s++;
2268             s = skipspace(s);
2269             if (isIDFIRST_lazy(s)) {
2270                 s = force_word(s,METHOD,FALSE,TRUE,FALSE);
2271                 TOKEN(ARROW);
2272             }
2273             else if (*s == '$')
2274                 OPERATOR(ARROW);
2275             else
2276                 TERM(ARROW);
2277         }
2278         if (PL_expect == XOPERATOR)
2279             Aop(OP_SUBTRACT);
2280         else {
2281             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2282                 check_uni();
2283             OPERATOR('-');              /* unary minus */
2284         }
2285
2286     case '+':
2287         tmp = *s++;
2288         if (*s == tmp) {
2289             s++;
2290             if (PL_expect == XOPERATOR)
2291                 TERM(POSTINC);
2292             else
2293                 OPERATOR(PREINC);
2294         }
2295         if (PL_expect == XOPERATOR)
2296             Aop(OP_ADD);
2297         else {
2298             if (isSPACE(*s) || !isSPACE(*PL_bufptr))
2299                 check_uni();
2300             OPERATOR('+');
2301         }
2302
2303     case '*':
2304         if (PL_expect != XOPERATOR) {
2305             s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2306             PL_expect = XOPERATOR;
2307             force_ident(PL_tokenbuf, '*');
2308             if (!*PL_tokenbuf)
2309                 PREREF('*');
2310             TERM('*');
2311         }
2312         s++;
2313         if (*s == '*') {
2314             s++;
2315             PWop(OP_POW);
2316         }
2317         Mop(OP_MULTIPLY);
2318
2319     case '%':
2320         if (PL_expect == XOPERATOR) {
2321             ++s;
2322             Mop(OP_MODULO);
2323         }
2324         PL_tokenbuf[0] = '%';
2325         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE);
2326         if (!PL_tokenbuf[1]) {
2327             if (s == PL_bufend)
2328                 yyerror("Final % should be \\% or %name");
2329             PREREF('%');
2330         }
2331         PL_pending_ident = '%';
2332         TERM('%');
2333
2334     case '^':
2335         s++;
2336         BOop(OP_BIT_XOR);
2337     case '[':
2338         PL_lex_brackets++;
2339         /* FALL THROUGH */
2340     case '~':
2341     case ',':
2342         tmp = *s++;
2343         OPERATOR(tmp);
2344     case ':':
2345         if (s[1] == ':') {
2346             len = 0;
2347             goto just_a_word;
2348         }
2349         s++;
2350         OPERATOR(':');
2351     case '(':
2352         s++;
2353         if (PL_last_lop == PL_oldoldbufptr || PL_last_uni == PL_oldoldbufptr)
2354             PL_oldbufptr = PL_oldoldbufptr;             /* allow print(STDOUT 123) */
2355         else
2356             PL_expect = XTERM;
2357         TOKEN('(');
2358     case ';':
2359         if (PL_curcop->cop_line < PL_copline)
2360             PL_copline = PL_curcop->cop_line;
2361         tmp = *s++;
2362         OPERATOR(tmp);
2363     case ')':
2364         tmp = *s++;
2365         s = skipspace(s);
2366         if (*s == '{')
2367             PREBLOCK(tmp);
2368         TERM(tmp);
2369     case ']':
2370         s++;
2371         if (PL_lex_brackets <= 0)
2372             yyerror("Unmatched right bracket");
2373         else
2374             --PL_lex_brackets;
2375         if (PL_lex_state == LEX_INTERPNORMAL) {
2376             if (PL_lex_brackets == 0) {
2377                 if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>'))
2378                     PL_lex_state = LEX_INTERPEND;
2379             }
2380         }
2381         TERM(']');
2382     case '{':
2383       leftbracket:
2384         s++;
2385         if (PL_lex_brackets > 100) {
2386             char* newlb = Renew(PL_lex_brackstack, PL_lex_brackets + 1, char);
2387             if (newlb != PL_lex_brackstack) {
2388                 SAVEFREEPV(newlb);
2389                 PL_lex_brackstack = newlb;
2390             }
2391         }
2392         switch (PL_expect) {
2393         case XTERM:
2394             if (PL_lex_formbrack) {
2395                 s--;
2396                 PRETERMBLOCK(DO);
2397             }
2398             if (PL_oldoldbufptr == PL_last_lop)
2399                 PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2400             else
2401                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2402             OPERATOR(HASHBRACK);
2403         case XOPERATOR:
2404             while (s < PL_bufend && (*s == ' ' || *s == '\t'))
2405                 s++;
2406             d = s;
2407             PL_tokenbuf[0] = '\0';
2408             if (d < PL_bufend && *d == '-') {
2409                 PL_tokenbuf[0] = '-';
2410                 d++;
2411                 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2412                     d++;
2413             }
2414             if (d < PL_bufend && isIDFIRST_lazy(d)) {
2415                 d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2416                               FALSE, &len);
2417                 while (d < PL_bufend && (*d == ' ' || *d == '\t'))
2418                     d++;
2419                 if (*d == '}') {
2420                     char minus = (PL_tokenbuf[0] == '-');
2421                     s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
2422                     if (minus)
2423                         force_next('-');
2424                 }
2425             }
2426             /* FALL THROUGH */
2427         case XBLOCK:
2428             PL_lex_brackstack[PL_lex_brackets++] = XSTATE;
2429             PL_expect = XSTATE;
2430             break;
2431         case XTERMBLOCK:
2432             PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2433             PL_expect = XSTATE;
2434             break;
2435         default: {
2436                 char *t;
2437                 if (PL_oldoldbufptr == PL_last_lop)
2438                     PL_lex_brackstack[PL_lex_brackets++] = XTERM;
2439                 else
2440                     PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
2441                 s = skipspace(s);
2442                 if (*s == '}')
2443                     OPERATOR(HASHBRACK);
2444                 /* This hack serves to disambiguate a pair of curlies
2445                  * as being a block or an anon hash.  Normally, expectation
2446                  * determines that, but in cases where we're not in a
2447                  * position to expect anything in particular (like inside
2448                  * eval"") we have to resolve the ambiguity.  This code
2449                  * covers the case where the first term in the curlies is a
2450                  * quoted string.  Most other cases need to be explicitly
2451                  * disambiguated by prepending a `+' before the opening
2452                  * curly in order to force resolution as an anon hash.
2453                  *
2454                  * XXX should probably propagate the outer expectation
2455                  * into eval"" to rely less on this hack, but that could
2456                  * potentially break current behavior of eval"".
2457                  * GSAR 97-07-21
2458                  */
2459                 t = s;
2460                 if (*s == '\'' || *s == '"' || *s == '`') {
2461                     /* common case: get past first string, handling escapes */
2462                     for (t++; t < PL_bufend && *t != *s;)
2463                         if (*t++ == '\\' && (*t == '\\' || *t == *s))
2464                             t++;
2465                     t++;
2466                 }
2467                 else if (*s == 'q') {
2468                     if (++t < PL_bufend
2469                         && (!isALNUM(*t)
2470                             || ((*t == 'q' || *t == 'x') && ++t < PL_bufend
2471                                 && !isALNUM(*t)))) {
2472                         char *tmps;
2473                         char open, close, term;
2474                         I32 brackets = 1;
2475
2476                         while (t < PL_bufend && isSPACE(*t))
2477                             t++;
2478                         term = *t;
2479                         open = term;
2480                         if (term && (tmps = strchr("([{< )]}> )]}>",term)))
2481                             term = tmps[5];
2482                         close = term;
2483                         if (open == close)
2484                             for (t++; t < PL_bufend; t++) {
2485                                 if (*t == '\\' && t+1 < PL_bufend && open != '\\')
2486                                     t++;
2487                                 else if (*t == open)
2488                                     break;
2489                             }
2490                         else
2491                             for (t++; t < PL_bufend; t++) {
2492                                 if (*t == '\\' && t+1 < PL_bufend)
2493                                     t++;
2494                                 else if (*t == close && --brackets <= 0)
2495                                     break;
2496                                 else if (*t == open)
2497                                     brackets++;
2498                             }
2499                     }
2500                     t++;
2501                 }
2502                 else if (isIDFIRST_lazy(s)) {
2503                     for (t++; t < PL_bufend && isALNUM_lazy(t); t++) ;
2504                 }
2505                 while (t < PL_bufend && isSPACE(*t))
2506                     t++;
2507                 /* if comma follows first term, call it an anon hash */
2508                 /* XXX it could be a comma expression with loop modifiers */
2509                 if (t < PL_bufend && ((*t == ',' && (*s == 'q' || !isLOWER(*s)))
2510                                    || (*t == '=' && t[1] == '>')))
2511                     OPERATOR(HASHBRACK);
2512                 if (PL_expect == XREF)
2513                     PL_expect = XSTATE; /* was XTERM, trying XSTATE */
2514                 else {
2515                     PL_lex_brackstack[PL_lex_brackets-1] = XSTATE;
2516                     PL_expect = XSTATE;
2517                 }
2518             }
2519             break;
2520         }
2521         yylval.ival = PL_curcop->cop_line;
2522         if (isSPACE(*s) || *s == '#')
2523             PL_copline = NOLINE;   /* invalidate current command line number */
2524         TOKEN('{');
2525     case '}':
2526       rightbracket:
2527         s++;
2528         if (PL_lex_brackets <= 0)
2529             yyerror("Unmatched right bracket");
2530         else
2531             PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets];
2532         if (PL_lex_brackets < PL_lex_formbrack)
2533             PL_lex_formbrack = 0;
2534         if (PL_lex_state == LEX_INTERPNORMAL) {
2535             if (PL_lex_brackets == 0) {
2536                 if (PL_lex_fakebrack) {
2537                     PL_lex_state = LEX_INTERPEND;
2538                     PL_bufptr = s;
2539                     return yylex(PERL_YYLEX_PARAM);     /* ignore fake brackets */
2540                 }
2541                 if (*s == '-' && s[1] == '>')
2542                     PL_lex_state = LEX_INTERPENDMAYBE;
2543                 else if (*s != '[' && *s != '{')
2544                     PL_lex_state = LEX_INTERPEND;
2545             }
2546         }
2547         if (PL_lex_brackets < PL_lex_fakebrack) {
2548             PL_bufptr = s;
2549             PL_lex_fakebrack = 0;
2550             return yylex(PERL_YYLEX_PARAM);             /* ignore fake brackets */
2551         }
2552         force_next('}');
2553         TOKEN(';');
2554     case '&':
2555         s++;
2556         tmp = *s++;
2557         if (tmp == '&')
2558             AOPERATOR(ANDAND);
2559         s--;
2560         if (PL_expect == XOPERATOR) {
2561             if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
2562                 PL_curcop->cop_line--;
2563                 warner(WARN_SEMICOLON, PL_warn_nosemi);
2564                 PL_curcop->cop_line++;
2565             }
2566             BAop(OP_BIT_AND);
2567         }
2568
2569         s = scan_ident(s - 1, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE);
2570         if (*PL_tokenbuf) {
2571             PL_expect = XOPERATOR;
2572             force_ident(PL_tokenbuf, '&');
2573         }
2574         else
2575             PREREF('&');
2576         yylval.ival = (OPpENTERSUB_AMPER<<8);
2577         TERM('&');
2578
2579     case '|':
2580         s++;
2581         tmp = *s++;
2582         if (tmp == '|')
2583             AOPERATOR(OROR);
2584         s--;
2585         BOop(OP_BIT_OR);
2586     case '=':
2587         s++;
2588         tmp = *s++;
2589         if (tmp == '=')
2590             Eop(OP_EQ);
2591         if (tmp == '>')
2592             OPERATOR(',');
2593         if (tmp == '~')
2594             PMop(OP_MATCH);
2595         if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
2596             warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
2597         s--;
2598         if (PL_expect == XSTATE && isALPHA(tmp) &&
2599                 (s == PL_linestart+1 || s[-2] == '\n') )
2600         {
2601             if (PL_in_eval && !PL_rsfp) {
2602                 d = PL_bufend;
2603                 while (s < d) {
2604                     if (*s++ == '\n') {
2605                         incline(s);
2606                         if (strnEQ(s,"=cut",4)) {
2607                             s = strchr(s,'\n');
2608                             if (s)
2609                                 s++;
2610                             else
2611                                 s = d;
2612                             incline(s);
2613                             goto retry;
2614                         }
2615                     }
2616                 }
2617                 goto retry;
2618             }
2619             s = PL_bufend;
2620             PL_doextract = TRUE;
2621             goto retry;
2622         }
2623         if (PL_lex_brackets < PL_lex_formbrack) {
2624             char *t;
2625 #ifdef PERL_STRICT_CR
2626             for (t = s; *t == ' ' || *t == '\t'; t++) ;
2627 #else
2628             for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ;
2629 #endif
2630             if (*t == '\n' || *t == '#') {
2631                 s--;
2632                 PL_expect = XBLOCK;
2633                 goto leftbracket;
2634             }
2635         }
2636         yylval.ival = 0;
2637         OPERATOR(ASSIGNOP);
2638     case '!':
2639         s++;
2640         tmp = *s++;
2641         if (tmp == '=')
2642             Eop(OP_NE);
2643         if (tmp == '~')
2644             PMop(OP_NOT);
2645         s--;
2646         OPERATOR('!');
2647     case '<':
2648         if (PL_expect != XOPERATOR) {
2649             if (s[1] != '<' && !strchr(s,'>'))
2650                 check_uni();
2651             if (s[1] == '<')
2652                 s = scan_heredoc(s);
2653             else
2654                 s = scan_inputsymbol(s);
2655             TERM(sublex_start());
2656         }
2657         s++;
2658         tmp = *s++;
2659         if (tmp == '<')
2660             SHop(OP_LEFT_SHIFT);
2661         if (tmp == '=') {
2662             tmp = *s++;
2663             if (tmp == '>')
2664                 Eop(OP_NCMP);
2665             s--;
2666             Rop(OP_LE);
2667         }
2668         s--;
2669         Rop(OP_LT);
2670     case '>':
2671         s++;
2672         tmp = *s++;
2673         if (tmp == '>')
2674             SHop(OP_RIGHT_SHIFT);
2675         if (tmp == '=')
2676             Rop(OP_GE);
2677         s--;
2678         Rop(OP_GT);
2679
2680     case '$':
2681         CLINE;
2682
2683         if (PL_expect == XOPERATOR) {
2684             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2685                 PL_expect = XTERM;
2686                 depcom();
2687                 return ','; /* grandfather non-comma-format format */
2688             }
2689         }
2690
2691         if (s[1] == '#' && (isIDFIRST_lazy(s+2) || strchr("{$:+-", s[2]))) {
2692             if (PL_expect == XOPERATOR)
2693                 no_op("Array length", PL_bufptr);
2694             PL_tokenbuf[0] = '@';
2695             s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1,
2696                            FALSE);
2697             if (!PL_tokenbuf[1])
2698                 PREREF(DOLSHARP);
2699             PL_expect = XOPERATOR;
2700             PL_pending_ident = '#';
2701             TOKEN(DOLSHARP);
2702         }
2703
2704         if (PL_expect == XOPERATOR)
2705             no_op("Scalar", PL_bufptr);
2706         PL_tokenbuf[0] = '$';
2707         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2708         if (!PL_tokenbuf[1]) {
2709             if (s == PL_bufend)
2710                 yyerror("Final $ should be \\$ or $name");
2711             PREREF('$');
2712         }
2713
2714         /* This kludge not intended to be bulletproof. */
2715         if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
2716             yylval.opval = newSVOP(OP_CONST, 0,
2717                                    newSViv((IV)PL_compiling.cop_arybase));
2718             yylval.opval->op_private = OPpCONST_ARYBASE;
2719             TERM(THING);
2720         }
2721
2722         d = s;
2723         if (PL_lex_state == LEX_NORMAL)
2724             s = skipspace(s);
2725
2726         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2727             char *t;
2728             if (*s == '[') {
2729                 PL_tokenbuf[0] = '@';
2730                 if (ckWARN(WARN_SYNTAX)) {
2731                     for(t = s + 1;
2732                         isSPACE(*t) || isALNUM_lazy(t) || *t == '$';
2733                         t++) ;
2734                     if (*t++ == ',') {
2735                         PL_bufptr = skipspace(PL_bufptr);
2736                         while (t < PL_bufend && *t != ']')
2737                             t++;
2738                         warner(WARN_SYNTAX,
2739                                 "Multidimensional syntax %.*s not supported",
2740                                 (t - PL_bufptr) + 1, PL_bufptr);
2741                     }
2742                 }
2743             }
2744             else if (*s == '{') {
2745                 PL_tokenbuf[0] = '%';
2746                 if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
2747                     (t = strchr(s, '}')) && (t = strchr(t, '=')))
2748                 {
2749                     char tmpbuf[sizeof PL_tokenbuf];
2750                     STRLEN len;
2751                     for (t++; isSPACE(*t); t++) ;
2752                     if (isIDFIRST_lazy(t)) {
2753                         t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
2754                         for (; isSPACE(*t); t++) ;
2755                         if (*t == ';' && perl_get_cv(tmpbuf, FALSE))
2756                             warner(WARN_SYNTAX,
2757                                 "You need to quote \"%s\"", tmpbuf);
2758                     }
2759                 }
2760             }
2761         }
2762
2763         PL_expect = XOPERATOR;
2764         if (PL_lex_state == LEX_NORMAL && isSPACE(*d)) {
2765             bool islop = (PL_last_lop == PL_oldoldbufptr);
2766             if (!islop || PL_last_lop_op == OP_GREPSTART)
2767                 PL_expect = XOPERATOR;
2768             else if (strchr("$@\"'`q", *s))
2769                 PL_expect = XTERM;              /* e.g. print $fh "foo" */
2770             else if (strchr("&*<%", *s) && isIDFIRST_lazy(s+1))
2771                 PL_expect = XTERM;              /* e.g. print $fh &sub */
2772             else if (isIDFIRST_lazy(s)) {
2773                 char tmpbuf[sizeof PL_tokenbuf];
2774                 scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
2775                 if (tmp = keyword(tmpbuf, len)) {
2776                     /* binary operators exclude handle interpretations */
2777                     switch (tmp) {
2778                     case -KEY_x:
2779                     case -KEY_eq:
2780                     case -KEY_ne:
2781                     case -KEY_gt:
2782                     case -KEY_lt:
2783                     case -KEY_ge:
2784                     case -KEY_le:
2785                     case -KEY_cmp:
2786                         break;
2787                     default:
2788                         PL_expect = XTERM;      /* e.g. print $fh length() */
2789                         break;
2790                     }
2791                 }
2792                 else {
2793                     GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV);
2794                     if (gv && GvCVu(gv))
2795                         PL_expect = XTERM;      /* e.g. print $fh subr() */
2796                 }
2797             }
2798             else if (isDIGIT(*s))
2799                 PL_expect = XTERM;              /* e.g. print $fh 3 */
2800             else if (*s == '.' && isDIGIT(s[1]))
2801                 PL_expect = XTERM;              /* e.g. print $fh .3 */
2802             else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
2803                 PL_expect = XTERM;              /* e.g. print $fh -1 */
2804             else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
2805                 PL_expect = XTERM;              /* print $fh <<"EOF" */
2806         }
2807         PL_pending_ident = '$';
2808         TOKEN('$');
2809
2810     case '@':
2811         if (PL_expect == XOPERATOR)
2812             no_op("Array", s);
2813         PL_tokenbuf[0] = '@';
2814         s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE);
2815         if (!PL_tokenbuf[1]) {
2816             if (s == PL_bufend)
2817                 yyerror("Final @ should be \\@ or @name");
2818             PREREF('@');
2819         }
2820         if (PL_lex_state == LEX_NORMAL)
2821             s = skipspace(s);
2822         if ((PL_expect != XREF || PL_oldoldbufptr == PL_last_lop) && intuit_more(s)) {
2823             if (*s == '{')
2824                 PL_tokenbuf[0] = '%';
2825
2826             /* Warn about @ where they meant $. */
2827             if (ckWARN(WARN_SYNTAX)) {
2828                 if (*s == '[' || *s == '{') {
2829                     char *t = s + 1;
2830                     while (*t && (isALNUM_lazy(t) || strchr(" \t$#+-'\"", *t)))
2831                         t++;
2832                     if (*t == '}' || *t == ']') {
2833                         t++;
2834                         PL_bufptr = skipspace(PL_bufptr);
2835                         warner(WARN_SYNTAX,
2836                             "Scalar value %.*s better written as $%.*s",
2837                             t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
2838                     }
2839                 }
2840             }
2841         }
2842         PL_pending_ident = '@';
2843         TERM('@');
2844
2845     case '/':                   /* may either be division or pattern */
2846     case '?':                   /* may either be conditional or pattern */
2847         if (PL_expect != XOPERATOR) {
2848             /* Disable warning on "study /blah/" */
2849             if (PL_oldoldbufptr == PL_last_uni
2850                 && (*PL_last_uni != 's' || s - PL_last_uni < 5
2851                     || memNE(PL_last_uni, "study", 5) || isALNUM_lazy(PL_last_uni+5)))
2852                 check_uni();
2853             s = scan_pat(s,OP_MATCH);
2854             TERM(sublex_start());
2855         }
2856         tmp = *s++;
2857         if (tmp == '/')
2858             Mop(OP_DIVIDE);
2859         OPERATOR(tmp);
2860
2861     case '.':
2862         if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack
2863 #ifdef PERL_STRICT_CR
2864             && s[1] == '\n'
2865 #else
2866             && (s[1] == '\n' || (s[1] == '\r' && s[2] == '\n'))
2867 #endif
2868             && (s == PL_linestart || s[-1] == '\n') )
2869         {
2870             PL_lex_formbrack = 0;
2871             PL_expect = XSTATE;
2872             goto rightbracket;
2873         }
2874         if (PL_expect == XOPERATOR || !isDIGIT(s[1])) {
2875             tmp = *s++;
2876             if (*s == tmp) {
2877                 s++;
2878                 if (*s == tmp) {
2879                     s++;
2880                     yylval.ival = OPf_SPECIAL;
2881                 }
2882                 else
2883                     yylval.ival = 0;
2884                 OPERATOR(DOTDOT);
2885             }
2886             if (PL_expect != XOPERATOR)
2887                 check_uni();
2888             Aop(OP_CONCAT);
2889         }
2890         /* FALL THROUGH */
2891     case '0': case '1': case '2': case '3': case '4':
2892     case '5': case '6': case '7': case '8': case '9':
2893         s = scan_num(s);
2894         if (PL_expect == XOPERATOR)
2895             no_op("Number",s);
2896         TERM(THING);
2897
2898     case '\'':
2899         s = scan_str(s);
2900         if (PL_expect == XOPERATOR) {
2901             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2902                 PL_expect = XTERM;
2903                 depcom();
2904                 return ',';     /* grandfather non-comma-format format */
2905             }
2906             else
2907                 no_op("String",s);
2908         }
2909         if (!s)
2910             missingterm((char*)0);
2911         yylval.ival = OP_CONST;
2912         TERM(sublex_start());
2913
2914     case '"':
2915         s = scan_str(s);
2916         if (PL_expect == XOPERATOR) {
2917             if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
2918                 PL_expect = XTERM;
2919                 depcom();
2920                 return ',';     /* grandfather non-comma-format format */
2921             }
2922             else
2923                 no_op("String",s);
2924         }
2925         if (!s)
2926             missingterm((char*)0);
2927         yylval.ival = OP_CONST;
2928         for (d = SvPV(PL_lex_stuff, len); len; len--, d++) {
2929             if (*d == '$' || *d == '@' || *d == '\\' || *d & 0x80) {
2930                 yylval.ival = OP_STRINGIFY;
2931                 break;
2932             }
2933         }
2934         TERM(sublex_start());
2935
2936     case '`':
2937         s = scan_str(s);
2938         if (PL_expect == XOPERATOR)
2939             no_op("Backticks",s);
2940         if (!s)
2941             missingterm((char*)0);
2942         yylval.ival = OP_BACKTICK;
2943         set_csh();
2944         TERM(sublex_start());
2945
2946     case '\\':
2947         s++;
2948         if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
2949             warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
2950                         *s, *s);
2951         if (PL_expect == XOPERATOR)
2952             no_op("Backslash",s);
2953         OPERATOR(REFGEN);
2954
2955     case 'x':
2956         if (isDIGIT(s[1]) && PL_expect == XOPERATOR) {
2957             s++;
2958             Mop(OP_REPEAT);
2959         }
2960         goto keylookup;
2961
2962     case '_':
2963     case 'a': case 'A':
2964     case 'b': case 'B':
2965     case 'c': case 'C':
2966     case 'd': case 'D':
2967     case 'e': case 'E':
2968     case 'f': case 'F':
2969     case 'g': case 'G':
2970     case 'h': case 'H':
2971     case 'i': case 'I':
2972     case 'j': case 'J':
2973     case 'k': case 'K':
2974     case 'l': case 'L':
2975     case 'm': case 'M':
2976     case 'n': case 'N':
2977     case 'o': case 'O':
2978     case 'p': case 'P':
2979     case 'q': case 'Q':
2980     case 'r': case 'R':
2981     case 's': case 'S':
2982     case 't': case 'T':
2983     case 'u': case 'U':
2984     case 'v': case 'V':
2985     case 'w': case 'W':
2986               case 'X':
2987     case 'y': case 'Y':
2988     case 'z': case 'Z':
2989
2990       keylookup: {
2991         STRLEN n_a;
2992         gv = Nullgv;
2993         gvp = 0;
2994
2995         PL_bufptr = s;
2996         s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
2997
2998         /* Some keywords can be followed by any delimiter, including ':' */
2999         tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) ||
3000                len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') ||
3001                             (PL_tokenbuf[0] == 'q' &&
3002                              strchr("qwxr", PL_tokenbuf[1]))));
3003
3004         /* x::* is just a word, unless x is "CORE" */
3005         if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE"))
3006             goto just_a_word;
3007
3008         d = s;
3009         while (d < PL_bufend && isSPACE(*d))
3010                 d++;    /* no comments skipped here, or s### is misparsed */
3011
3012         /* Is this a label? */
3013         if (!tmp && PL_expect == XSTATE
3014               && d < PL_bufend && *d == ':' && *(d + 1) != ':') {
3015             s = d + 1;
3016             yylval.pval = savepv(PL_tokenbuf);
3017             CLINE;
3018             TOKEN(LABEL);
3019         }
3020
3021         /* Check for keywords */
3022         tmp = keyword(PL_tokenbuf, len);
3023
3024         /* Is this a word before a => operator? */
3025         if (strnEQ(d,"=>",2)) {
3026             CLINE;
3027             yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
3028             yylval.opval->op_private = OPpCONST_BARE;
3029             TERM(WORD);
3030         }
3031
3032         if (tmp < 0) {                  /* second-class keyword? */
3033             GV *ogv = Nullgv;   /* override (winner) */
3034             GV *hgv = Nullgv;   /* hidden (loser) */
3035             if (PL_expect != XOPERATOR && (*s != ':' || s[1] != ':')) {
3036                 CV *cv;
3037                 if ((gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV)) &&
3038                     (cv = GvCVu(gv)))
3039                 {
3040                     if (GvIMPORTED_CV(gv))
3041                         ogv = gv;
3042                     else if (! CvMETHOD(cv))
3043                         hgv = gv;
3044                 }
3045                 if (!ogv &&
3046                     (gvp = (GV**)hv_fetch(PL_globalstash,PL_tokenbuf,len,FALSE)) &&
3047                     (gv = *gvp) != (GV*)&PL_sv_undef &&
3048                     GvCVu(gv) && GvIMPORTED_CV(gv))
3049                 {
3050                     ogv = gv;
3051                 }
3052             }
3053             if (ogv) {
3054                 tmp = 0;                /* overridden by import or by GLOBAL */
3055             }
3056             else if (gv && !gvp
3057                      && -tmp==KEY_lock  /* XXX generalizable kludge */
3058                      && !hv_fetch(GvHVn(PL_incgv), "Thread.pm", 9, FALSE))
3059             {
3060                 tmp = 0;                /* any sub overrides "weak" keyword */
3061             }
3062             else {                      /* no override */
3063                 tmp = -tmp;
3064                 gv = Nullgv;
3065                 gvp = 0;
3066                 if (ckWARN(WARN_AMBIGUOUS) && hgv
3067                     && tmp != KEY_x && tmp != KEY_CORE) /* never ambiguous */
3068                     warner(WARN_AMBIGUOUS,
3069                         "Ambiguous call resolved as CORE::%s(), %s",
3070                          GvENAME(hgv), "qualify as such or use &");
3071             }
3072         }
3073
3074       reserved_word:
3075         switch (tmp) {
3076
3077         default:                        /* not a keyword */
3078           just_a_word: {
3079                 SV *sv;
3080                 char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]);
3081
3082                 /* Get the rest if it looks like a package qualifier */
3083
3084                 if (*s == '\'' || *s == ':' && s[1] == ':') {
3085                     STRLEN morelen;
3086                     s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len,
3087                                   TRUE, &morelen);
3088                     if (!morelen)
3089                         croak("Bad name after %s%s", PL_tokenbuf,
3090                                 *s == '\'' ? "'" : "::");
3091                     len += morelen;
3092                 }
3093
3094                 if (PL_expect == XOPERATOR) {
3095                     if (PL_bufptr == PL_linestart) {
3096                         PL_curcop->cop_line--;
3097                         warner(WARN_SEMICOLON, PL_warn_nosemi);
3098                         PL_curcop->cop_line++;
3099                     }
3100                     else
3101                         no_op("Bareword",s);
3102                 }
3103
3104                 /* Look for a subroutine with this name in current package,
3105                    unless name is "Foo::", in which case Foo is a bearword
3106                    (and a package name). */
3107
3108                 if (len > 2 &&
3109                     PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
3110                 {
3111                     if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
3112                         warner(WARN_UNSAFE,
3113                             "Bareword \"%s\" refers to nonexistent package",
3114                              PL_tokenbuf);
3115                     len -= 2;
3116                     PL_tokenbuf[len] = '\0';
3117                     gv = Nullgv;
3118                     gvp = 0;
3119                 }
3120                 else {
3121                     len = 0;
3122                     if (!gv)
3123                         gv = gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVCV);
3124                 }
3125
3126                 /* if we saw a global override before, get the right name */
3127
3128                 if (gvp) {
3129                     sv = newSVpv("CORE::GLOBAL::",14);
3130                     sv_catpv(sv,PL_tokenbuf);
3131                 }
3132                 else
3133                     sv = newSVpv(PL_tokenbuf,0);
3134
3135                 /* Presume this is going to be a bareword of some sort. */
3136
3137                 CLINE;
3138                 yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv);
3139                 yylval.opval->op_private = OPpCONST_BARE;
3140
3141                 /* And if "Foo::", then that's what it certainly is. */
3142
3143                 if (len)
3144                     goto safe_bareword;
3145
3146                 /* See if it's the indirect object for a list operator. */
3147
3148                 if (PL_oldoldbufptr &&
3149                     PL_oldoldbufptr < PL_bufptr &&
3150                     (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
3151                     /* NO SKIPSPACE BEFORE HERE! */
3152                     (PL_expect == XREF
3153                      || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
3154                      || (PL_last_lop_op == OP_ENTERSUB
3155                          && PL_last_proto
3156                          && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
3157                 {
3158                     bool immediate_paren = *s == '(';
3159
3160                     /* (Now we can afford to cross potential line boundary.) */
3161                     s = skipspace(s);
3162
3163                     /* Two barewords in a row may indicate method call. */
3164
3165                     if ((isIDFIRST_lazy(s) || *s == '$') && (tmp=intuit_method(s,gv)))
3166                         return tmp;
3167
3168                     /* If not a declared subroutine, it's an indirect object. */
3169                     /* (But it's an indir obj regardless for sort.) */
3170
3171                     if ((PL_last_lop_op == OP_SORT ||
3172                          (!immediate_paren && (!gv || !GvCVu(gv))) ) &&
3173                         (PL_last_lop_op != OP_MAPSTART && PL_last_lop_op != OP_GREPSTART)){
3174                         PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
3175                         goto bareword;
3176                     }
3177                 }
3178
3179                 /* If followed by a paren, it's certainly a subroutine. */
3180
3181                 PL_expect = XOPERATOR;
3182                 s = skipspace(s);
3183                 if (*s == '(') {
3184                     CLINE;
3185                     if (gv && GvCVu(gv)) {
3186                         CV *cv;
3187                         if ((cv = GvCV(gv)) && SvPOK(cv))
3188                             PL_last_proto = SvPV((SV*)cv, n_a);
3189                         for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3190                         if (*d == ')' && (sv = cv_const_sv(cv))) {
3191                             s = d + 1;
3192                             goto its_constant;
3193                         }
3194                     }
3195                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3196                     PL_expect = XOPERATOR;
3197                     force_next(WORD);
3198                     yylval.ival = 0;
3199                     PL_last_lop_op = OP_ENTERSUB;
3200                     TOKEN('&');
3201                 }
3202
3203                 /* If followed by var or block, call it a method (unless sub) */
3204
3205                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3206                     PL_last_lop = PL_oldbufptr;
3207                     PL_last_lop_op = OP_METHOD;
3208                     PREBLOCK(METHOD);
3209                 }
3210
3211                 /* If followed by a bareword, see if it looks like indir obj. */
3212
3213                 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3214                     return tmp;
3215
3216                 /* Not a method, so call it a subroutine (if defined) */
3217
3218                 if (gv && GvCVu(gv)) {
3219                     CV* cv;
3220                     if (lastchar == '-')
3221                         warn("Ambiguous use of -%s resolved as -&%s()",
3222                                 PL_tokenbuf, PL_tokenbuf);
3223                     PL_last_lop = PL_oldbufptr;
3224                     PL_last_lop_op = OP_ENTERSUB;
3225                     /* Check for a constant sub */
3226                     cv = GvCV(gv);
3227                     if ((sv = cv_const_sv(cv))) {
3228                   its_constant:
3229                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3230                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3231                         yylval.opval->op_private = 0;
3232                         TOKEN(WORD);
3233                     }
3234
3235                     /* Resolve to GV now. */
3236                     op_free(yylval.opval);
3237                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3238                     PL_last_lop_op = OP_ENTERSUB;
3239                     /* Is there a prototype? */
3240                     if (SvPOK(cv)) {
3241                         STRLEN len;
3242                         PL_last_proto = SvPV((SV*)cv, len);
3243                         if (!len)
3244                             TERM(FUNC0SUB);
3245                         if (strEQ(PL_last_proto, "$"))
3246                             OPERATOR(UNIOPSUB);
3247                         if (*PL_last_proto == '&' && *s == '{') {
3248                             sv_setpv(PL_subname,"__ANON__");
3249                             PREBLOCK(LSTOPSUB);
3250                         }
3251                     } else
3252                         PL_last_proto = NULL;
3253                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3254                     PL_expect = XTERM;
3255                     force_next(WORD);
3256                     TOKEN(NOAMP);
3257                 }
3258
3259                 if (PL_hints & HINT_STRICT_SUBS &&
3260                     lastchar != '-' &&
3261                     strnNE(s,"->",2) &&
3262                     PL_last_lop_op != OP_TRUNCATE &&  /* S/F prototype in opcode.pl */
3263                     PL_last_lop_op != OP_ACCEPT &&
3264                     PL_last_lop_op != OP_PIPE_OP &&
3265                     PL_last_lop_op != OP_SOCKPAIR &&
3266                     !(PL_last_lop_op == OP_ENTERSUB
3267                          && PL_last_proto
3268                          && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3269                 {
3270                     warn(
3271                      "Bareword \"%s\" not allowed while \"strict subs\" in use",
3272                         PL_tokenbuf);
3273                     ++PL_error_count;
3274                 }
3275
3276                 /* Call it a bare word */
3277
3278             bareword:
3279                 if (ckWARN(WARN_RESERVED)) {
3280                     if (lastchar != '-') {
3281                         for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3282                         if (!*d)
3283                             warner(WARN_RESERVED, PL_warn_reserved, PL_tokenbuf);
3284                     }
3285                 }
3286
3287             safe_bareword:
3288                 if (lastchar && strchr("*%&", lastchar)) {
3289                     warn("Operator or semicolon missing before %c%s",
3290                         lastchar, PL_tokenbuf);
3291                     warn("Ambiguous use of %c resolved as operator %c",
3292                         lastchar, lastchar);
3293                 }
3294                 TOKEN(WORD);
3295             }
3296
3297         case KEY___FILE__:
3298             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3299                                         newSVsv(GvSV(PL_curcop->cop_filegv)));
3300             TERM(THING);
3301
3302         case KEY___LINE__:
3303             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3304                                     newSVpvf("%ld", (long)PL_curcop->cop_line));
3305             TERM(THING);
3306
3307         case KEY___PACKAGE__:
3308             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3309                                         (PL_curstash
3310                                          ? newSVsv(PL_curstname)
3311                                          : &PL_sv_undef));
3312             TERM(THING);
3313
3314         case KEY___DATA__:
3315         case KEY___END__: {
3316             GV *gv;
3317
3318             /*SUPPRESS 560*/
3319             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3320                 char *pname = "main";
3321                 if (PL_tokenbuf[2] == 'D')
3322                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3323                 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3324                 GvMULTI_on(gv);
3325                 if (!GvIO(gv))
3326                     GvIOp(gv) = newIO();
3327                 IoIFP(GvIOp(gv)) = PL_rsfp;
3328 #if defined(HAS_FCNTL) && defined(F_SETFD)
3329                 {
3330                     int fd = PerlIO_fileno(PL_rsfp);
3331                     fcntl(fd,F_SETFD,fd >= 3);
3332                 }
3333 #endif
3334                 /* Mark this internal pseudo-handle as clean */
3335                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3336                 if (PL_preprocess)
3337                     IoTYPE(GvIOp(gv)) = '|';
3338                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3339                     IoTYPE(GvIOp(gv)) = '-';
3340                 else
3341                     IoTYPE(GvIOp(gv)) = '<';
3342                 PL_rsfp = Nullfp;
3343             }
3344             goto fake_eof;
3345         }
3346
3347         case KEY_AUTOLOAD:
3348         case KEY_DESTROY:
3349         case KEY_BEGIN:
3350         case KEY_END:
3351         case KEY_INIT:
3352             if (PL_expect == XSTATE) {
3353                 s = PL_bufptr;
3354                 goto really_sub;
3355             }
3356             goto just_a_word;
3357
3358         case KEY_CORE:
3359             if (*s == ':' && s[1] == ':') {
3360                 s += 2;
3361                 d = s;
3362                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3363                 tmp = keyword(PL_tokenbuf, len);
3364                 if (tmp < 0)
3365                     tmp = -tmp;
3366                 goto reserved_word;
3367             }
3368             goto just_a_word;
3369
3370         case KEY_abs:
3371             UNI(OP_ABS);
3372
3373         case KEY_alarm:
3374             UNI(OP_ALARM);
3375
3376         case KEY_accept:
3377             LOP(OP_ACCEPT,XTERM);
3378
3379         case KEY_and:
3380             OPERATOR(ANDOP);
3381
3382         case KEY_atan2:
3383             LOP(OP_ATAN2,XTERM);
3384
3385         case KEY_bind:
3386             LOP(OP_BIND,XTERM);
3387
3388         case KEY_binmode:
3389             UNI(OP_BINMODE);
3390
3391         case KEY_bless:
3392             LOP(OP_BLESS,XTERM);
3393
3394         case KEY_chop:
3395             UNI(OP_CHOP);
3396
3397         case KEY_continue:
3398             PREBLOCK(CONTINUE);
3399
3400         case KEY_chdir:
3401             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
3402             UNI(OP_CHDIR);
3403
3404         case KEY_close:
3405             UNI(OP_CLOSE);
3406
3407         case KEY_closedir:
3408             UNI(OP_CLOSEDIR);
3409
3410         case KEY_cmp:
3411             Eop(OP_SCMP);
3412
3413         case KEY_caller:
3414             UNI(OP_CALLER);
3415
3416         case KEY_crypt:
3417 #ifdef FCRYPT
3418             if (!PL_cryptseen++)
3419                 init_des();
3420 #endif
3421             LOP(OP_CRYPT,XTERM);
3422
3423         case KEY_chmod:
3424             if (ckWARN(WARN_OCTAL)) {
3425                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3426                 if (*d != '0' && isDIGIT(*d))
3427                     yywarn("chmod: mode argument is missing initial 0");
3428             }
3429             LOP(OP_CHMOD,XTERM);
3430
3431         case KEY_chown:
3432             LOP(OP_CHOWN,XTERM);
3433
3434         case KEY_connect:
3435             LOP(OP_CONNECT,XTERM);
3436
3437         case KEY_chr:
3438             UNI(OP_CHR);
3439
3440         case KEY_cos:
3441             UNI(OP_COS);
3442
3443         case KEY_chroot:
3444             UNI(OP_CHROOT);
3445
3446         case KEY_do:
3447             s = skipspace(s);
3448             if (*s == '{')
3449                 PRETERMBLOCK(DO);
3450             if (*s != '\'')
3451                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3452             OPERATOR(DO);
3453
3454         case KEY_die:
3455             PL_hints |= HINT_BLOCK_SCOPE;
3456             LOP(OP_DIE,XTERM);
3457
3458         case KEY_defined:
3459             UNI(OP_DEFINED);
3460
3461         case KEY_delete:
3462             UNI(OP_DELETE);
3463
3464         case KEY_dbmopen:
3465             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3466             LOP(OP_DBMOPEN,XTERM);
3467
3468         case KEY_dbmclose:
3469             UNI(OP_DBMCLOSE);
3470
3471         case KEY_dump:
3472             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3473             LOOPX(OP_DUMP);
3474
3475         case KEY_else:
3476             PREBLOCK(ELSE);
3477
3478         case KEY_elsif:
3479             yylval.ival = PL_curcop->cop_line;
3480             OPERATOR(ELSIF);
3481
3482         case KEY_eq:
3483             Eop(OP_SEQ);
3484
3485         case KEY_exists:
3486             UNI(OP_EXISTS);
3487
3488         case KEY_exit:
3489             UNI(OP_EXIT);
3490
3491         case KEY_eval:
3492             s = skipspace(s);
3493             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3494             UNIBRACK(OP_ENTEREVAL);
3495
3496         case KEY_eof:
3497             UNI(OP_EOF);
3498
3499         case KEY_exp:
3500             UNI(OP_EXP);
3501
3502         case KEY_each:
3503             UNI(OP_EACH);
3504
3505         case KEY_exec:
3506             set_csh();
3507             LOP(OP_EXEC,XREF);
3508
3509         case KEY_endhostent:
3510             FUN0(OP_EHOSTENT);
3511
3512         case KEY_endnetent:
3513             FUN0(OP_ENETENT);
3514
3515         case KEY_endservent:
3516             FUN0(OP_ESERVENT);
3517
3518         case KEY_endprotoent:
3519             FUN0(OP_EPROTOENT);
3520
3521         case KEY_endpwent:
3522             FUN0(OP_EPWENT);
3523
3524         case KEY_endgrent:
3525             FUN0(OP_EGRENT);
3526
3527         case KEY_for:
3528         case KEY_foreach:
3529             yylval.ival = PL_curcop->cop_line;
3530             s = skipspace(s);
3531             if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3532                 char *p = s;
3533                 if ((PL_bufend - p) >= 3 &&
3534                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3535                     p += 2;
3536                 p = skipspace(p);
3537                 if (isIDFIRST_lazy(p))
3538                     croak("Missing $ on loop variable");
3539             }
3540             OPERATOR(FOR);
3541
3542         case KEY_formline:
3543             LOP(OP_FORMLINE,XTERM);
3544
3545         case KEY_fork:
3546             FUN0(OP_FORK);
3547
3548         case KEY_fcntl:
3549             LOP(OP_FCNTL,XTERM);
3550
3551         case KEY_fileno:
3552             UNI(OP_FILENO);
3553
3554         case KEY_flock:
3555             LOP(OP_FLOCK,XTERM);
3556
3557         case KEY_gt:
3558             Rop(OP_SGT);
3559
3560         case KEY_ge:
3561             Rop(OP_SGE);
3562
3563         case KEY_grep:
3564             LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3565
3566         case KEY_goto:
3567             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3568             LOOPX(OP_GOTO);
3569
3570         case KEY_gmtime:
3571             UNI(OP_GMTIME);
3572
3573         case KEY_getc:
3574             UNI(OP_GETC);
3575
3576         case KEY_getppid:
3577             FUN0(OP_GETPPID);
3578
3579         case KEY_getpgrp:
3580             UNI(OP_GETPGRP);
3581
3582         case KEY_getpriority:
3583             LOP(OP_GETPRIORITY,XTERM);
3584
3585         case KEY_getprotobyname:
3586             UNI(OP_GPBYNAME);
3587
3588         case KEY_getprotobynumber:
3589             LOP(OP_GPBYNUMBER,XTERM);
3590
3591         case KEY_getprotoent:
3592             FUN0(OP_GPROTOENT);
3593
3594         case KEY_getpwent:
3595             FUN0(OP_GPWENT);
3596
3597         case KEY_getpwnam:
3598             UNI(OP_GPWNAM);
3599
3600         case KEY_getpwuid:
3601             UNI(OP_GPWUID);
3602
3603         case KEY_getpeername:
3604             UNI(OP_GETPEERNAME);
3605
3606         case KEY_gethostbyname:
3607             UNI(OP_GHBYNAME);
3608
3609         case KEY_gethostbyaddr:
3610             LOP(OP_GHBYADDR,XTERM);
3611
3612         case KEY_gethostent:
3613             FUN0(OP_GHOSTENT);
3614
3615         case KEY_getnetbyname:
3616             UNI(OP_GNBYNAME);
3617
3618         case KEY_getnetbyaddr:
3619             LOP(OP_GNBYADDR,XTERM);
3620
3621         case KEY_getnetent:
3622             FUN0(OP_GNETENT);
3623
3624         case KEY_getservbyname:
3625             LOP(OP_GSBYNAME,XTERM);
3626
3627         case KEY_getservbyport:
3628             LOP(OP_GSBYPORT,XTERM);
3629
3630         case KEY_getservent:
3631             FUN0(OP_GSERVENT);
3632
3633         case KEY_getsockname:
3634             UNI(OP_GETSOCKNAME);
3635
3636         case KEY_getsockopt:
3637             LOP(OP_GSOCKOPT,XTERM);
3638
3639         case KEY_getgrent:
3640             FUN0(OP_GGRENT);
3641
3642         case KEY_getgrnam:
3643             UNI(OP_GGRNAM);
3644
3645         case KEY_getgrgid:
3646             UNI(OP_GGRGID);
3647
3648         case KEY_getlogin:
3649             FUN0(OP_GETLOGIN);
3650
3651         case KEY_glob:
3652             set_csh();
3653             LOP(OP_GLOB,XTERM);
3654
3655         case KEY_hex:
3656             UNI(OP_HEX);
3657
3658         case KEY_if:
3659             yylval.ival = PL_curcop->cop_line;
3660             OPERATOR(IF);
3661
3662         case KEY_index:
3663             LOP(OP_INDEX,XTERM);
3664
3665         case KEY_int:
3666             UNI(OP_INT);
3667
3668         case KEY_ioctl:
3669             LOP(OP_IOCTL,XTERM);
3670
3671         case KEY_join:
3672             LOP(OP_JOIN,XTERM);
3673
3674         case KEY_keys:
3675             UNI(OP_KEYS);
3676
3677         case KEY_kill:
3678             LOP(OP_KILL,XTERM);
3679
3680         case KEY_last:
3681             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3682             LOOPX(OP_LAST);
3683
3684         case KEY_lc:
3685             UNI(OP_LC);
3686
3687         case KEY_lcfirst:
3688             UNI(OP_LCFIRST);
3689
3690         case KEY_local:
3691             OPERATOR(LOCAL);
3692
3693         case KEY_length:
3694             UNI(OP_LENGTH);
3695
3696         case KEY_lt:
3697             Rop(OP_SLT);
3698
3699         case KEY_le:
3700             Rop(OP_SLE);
3701
3702         case KEY_localtime:
3703             UNI(OP_LOCALTIME);
3704
3705         case KEY_log:
3706             UNI(OP_LOG);
3707
3708         case KEY_link:
3709             LOP(OP_LINK,XTERM);
3710
3711         case KEY_listen:
3712             LOP(OP_LISTEN,XTERM);
3713
3714         case KEY_lock:
3715             UNI(OP_LOCK);
3716
3717         case KEY_lstat:
3718             UNI(OP_LSTAT);
3719
3720         case KEY_m:
3721             s = scan_pat(s,OP_MATCH);
3722             TERM(sublex_start());
3723
3724         case KEY_map:
3725             LOP(OP_MAPSTART, XREF);
3726
3727         case KEY_mkdir:
3728             LOP(OP_MKDIR,XTERM);
3729
3730         case KEY_msgctl:
3731             LOP(OP_MSGCTL,XTERM);
3732
3733         case KEY_msgget:
3734             LOP(OP_MSGGET,XTERM);
3735
3736         case KEY_msgrcv:
3737             LOP(OP_MSGRCV,XTERM);
3738
3739         case KEY_msgsnd:
3740             LOP(OP_MSGSND,XTERM);
3741
3742         case KEY_my:
3743             PL_in_my = TRUE;
3744             s = skipspace(s);
3745             if (isIDFIRST_lazy(s)) {
3746                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3747                 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3748                 if (!PL_in_my_stash) {
3749                     char tmpbuf[1024];
3750                     PL_bufptr = s;
3751                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3752                     yyerror(tmpbuf);
3753                 }
3754             }
3755             OPERATOR(MY);
3756
3757         case KEY_next:
3758             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3759             LOOPX(OP_NEXT);
3760
3761         case KEY_ne:
3762             Eop(OP_SNE);
3763
3764         case KEY_no:
3765             if (PL_expect != XSTATE)
3766                 yyerror("\"no\" not allowed in expression");
3767             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3768             s = force_version(s);
3769             yylval.ival = 0;
3770             OPERATOR(USE);
3771
3772         case KEY_not:
3773             OPERATOR(NOTOP);
3774
3775         case KEY_open:
3776             s = skipspace(s);
3777             if (isIDFIRST_lazy(s)) {
3778                 char *t;
3779                 for (d = s; isALNUM_lazy(d); d++) ;
3780                 t = skipspace(d);
3781                 if (strchr("|&*+-=!?:.", *t))
3782                     warn("Precedence problem: open %.*s should be open(%.*s)",
3783                         d-s,s, d-s,s);
3784             }
3785             LOP(OP_OPEN,XTERM);
3786
3787         case KEY_or:
3788             yylval.ival = OP_OR;
3789             OPERATOR(OROP);
3790
3791         case KEY_ord:
3792             UNI(OP_ORD);
3793
3794         case KEY_oct:
3795             UNI(OP_OCT);
3796
3797         case KEY_opendir:
3798             LOP(OP_OPEN_DIR,XTERM);
3799
3800         case KEY_print:
3801             checkcomma(s,PL_tokenbuf,"filehandle");
3802             LOP(OP_PRINT,XREF);
3803
3804         case KEY_printf:
3805             checkcomma(s,PL_tokenbuf,"filehandle");
3806             LOP(OP_PRTF,XREF);
3807
3808         case KEY_prototype:
3809             UNI(OP_PROTOTYPE);
3810
3811         case KEY_push:
3812             LOP(OP_PUSH,XTERM);
3813
3814         case KEY_pop:
3815             UNI(OP_POP);
3816
3817         case KEY_pos:
3818             UNI(OP_POS);
3819
3820         case KEY_pack:
3821             LOP(OP_PACK,XTERM);
3822
3823         case KEY_package:
3824             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3825             OPERATOR(PACKAGE);
3826
3827         case KEY_pipe:
3828             LOP(OP_PIPE_OP,XTERM);
3829
3830         case KEY_q:
3831             s = scan_str(s);
3832             if (!s)
3833                 missingterm((char*)0);
3834             yylval.ival = OP_CONST;
3835             TERM(sublex_start());
3836
3837         case KEY_quotemeta:
3838             UNI(OP_QUOTEMETA);
3839
3840         case KEY_qw:
3841             s = scan_str(s);
3842             if (!s)
3843                 missingterm((char*)0);
3844             if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3845                 d = SvPV_force(PL_lex_stuff, len);
3846                 for (; len; --len, ++d) {
3847                     if (*d == ',') {
3848                         warner(WARN_SYNTAX,
3849                             "Possible attempt to separate words with commas");
3850                         break;
3851                     }
3852                     if (*d == '#') {
3853                         warner(WARN_SYNTAX,
3854                             "Possible attempt to put comments in qw() list");
3855                         break;
3856                     }
3857                 }
3858             }
3859             force_next(')');
3860             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3861             PL_lex_stuff = Nullsv;
3862             force_next(THING);
3863             force_next(',');
3864             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3865             force_next(THING);
3866             force_next('(');
3867             yylval.ival = OP_SPLIT;
3868             CLINE;
3869             PL_expect = XTERM;
3870             PL_bufptr = s;
3871             PL_last_lop = PL_oldbufptr;
3872             PL_last_lop_op = OP_SPLIT;
3873             return FUNC;
3874
3875         case KEY_qq:
3876             s = scan_str(s);
3877             if (!s)
3878                 missingterm((char*)0);
3879             yylval.ival = OP_STRINGIFY;
3880             if (SvIVX(PL_lex_stuff) == '\'')
3881                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
3882             TERM(sublex_start());
3883
3884         case KEY_qr:
3885             s = scan_pat(s,OP_QR);
3886             TERM(sublex_start());
3887
3888         case KEY_qx:
3889             s = scan_str(s);
3890             if (!s)
3891                 missingterm((char*)0);
3892             yylval.ival = OP_BACKTICK;
3893             set_csh();
3894             TERM(sublex_start());
3895
3896         case KEY_return:
3897             OLDLOP(OP_RETURN);
3898
3899         case KEY_require:
3900             *PL_tokenbuf = '\0';
3901             s = force_word(s,WORD,TRUE,TRUE,FALSE);
3902             if (isIDFIRST_lazy(PL_tokenbuf))
3903                 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3904             else if (*s == '<')
3905                 yyerror("<> should be quotes");
3906             UNI(OP_REQUIRE);
3907
3908         case KEY_reset:
3909             UNI(OP_RESET);
3910
3911         case KEY_redo:
3912             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3913             LOOPX(OP_REDO);
3914
3915         case KEY_rename:
3916             LOP(OP_RENAME,XTERM);
3917
3918         case KEY_rand:
3919             UNI(OP_RAND);
3920
3921         case KEY_rmdir:
3922             UNI(OP_RMDIR);
3923
3924         case KEY_rindex:
3925             LOP(OP_RINDEX,XTERM);
3926
3927         case KEY_read:
3928             LOP(OP_READ,XTERM);
3929
3930         case KEY_readdir:
3931             UNI(OP_READDIR);
3932
3933         case KEY_readline:
3934             set_csh();
3935             UNI(OP_READLINE);
3936
3937         case KEY_readpipe:
3938             set_csh();
3939             UNI(OP_BACKTICK);
3940
3941         case KEY_rewinddir:
3942             UNI(OP_REWINDDIR);
3943
3944         case KEY_recv:
3945             LOP(OP_RECV,XTERM);
3946
3947         case KEY_reverse:
3948             LOP(OP_REVERSE,XTERM);
3949
3950         case KEY_readlink:
3951             UNI(OP_READLINK);
3952
3953         case KEY_ref:
3954             UNI(OP_REF);
3955
3956         case KEY_s:
3957             s = scan_subst(s);
3958             if (yylval.opval)
3959                 TERM(sublex_start());
3960             else
3961                 TOKEN(1);       /* force error */
3962
3963         case KEY_chomp:
3964             UNI(OP_CHOMP);
3965
3966         case KEY_scalar:
3967             UNI(OP_SCALAR);
3968
3969         case KEY_select:
3970             LOP(OP_SELECT,XTERM);
3971
3972         case KEY_seek:
3973             LOP(OP_SEEK,XTERM);
3974
3975         case KEY_semctl:
3976             LOP(OP_SEMCTL,XTERM);
3977
3978         case KEY_semget:
3979             LOP(OP_SEMGET,XTERM);
3980
3981         case KEY_semop:
3982             LOP(OP_SEMOP,XTERM);
3983
3984         case KEY_send:
3985             LOP(OP_SEND,XTERM);
3986
3987         case KEY_setpgrp:
3988             LOP(OP_SETPGRP,XTERM);
3989
3990         case KEY_setpriority:
3991             LOP(OP_SETPRIORITY,XTERM);
3992
3993         case KEY_sethostent:
3994             UNI(OP_SHOSTENT);
3995
3996         case KEY_setnetent:
3997             UNI(OP_SNETENT);
3998
3999         case KEY_setservent:
4000             UNI(OP_SSERVENT);
4001
4002         case KEY_setprotoent:
4003             UNI(OP_SPROTOENT);
4004
4005         case KEY_setpwent:
4006             FUN0(OP_SPWENT);
4007
4008         case KEY_setgrent:
4009             FUN0(OP_SGRENT);
4010
4011         case KEY_seekdir:
4012             LOP(OP_SEEKDIR,XTERM);
4013
4014         case KEY_setsockopt:
4015             LOP(OP_SSOCKOPT,XTERM);
4016
4017         case KEY_shift:
4018             UNI(OP_SHIFT);
4019
4020         case KEY_shmctl:
4021             LOP(OP_SHMCTL,XTERM);
4022
4023         case KEY_shmget:
4024             LOP(OP_SHMGET,XTERM);
4025
4026         case KEY_shmread:
4027             LOP(OP_SHMREAD,XTERM);
4028
4029         case KEY_shmwrite:
4030             LOP(OP_SHMWRITE,XTERM);
4031
4032         case KEY_shutdown:
4033             LOP(OP_SHUTDOWN,XTERM);
4034
4035         case KEY_sin:
4036             UNI(OP_SIN);
4037
4038         case KEY_sleep:
4039             UNI(OP_SLEEP);
4040
4041         case KEY_socket:
4042             LOP(OP_SOCKET,XTERM);
4043
4044         case KEY_socketpair:
4045             LOP(OP_SOCKPAIR,XTERM);
4046
4047         case KEY_sort:
4048             checkcomma(s,PL_tokenbuf,"subroutine name");
4049             s = skipspace(s);
4050             if (*s == ';' || *s == ')')         /* probably a close */
4051                 croak("sort is now a reserved word");
4052             PL_expect = XTERM;
4053             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4054             LOP(OP_SORT,XREF);
4055
4056         case KEY_split:
4057             LOP(OP_SPLIT,XTERM);
4058
4059         case KEY_sprintf:
4060             LOP(OP_SPRINTF,XTERM);
4061
4062         case KEY_splice:
4063             LOP(OP_SPLICE,XTERM);
4064
4065         case KEY_sqrt:
4066             UNI(OP_SQRT);
4067
4068         case KEY_srand:
4069             UNI(OP_SRAND);
4070
4071         case KEY_stat:
4072             UNI(OP_STAT);
4073
4074         case KEY_study:
4075             PL_sawstudy++;
4076             UNI(OP_STUDY);
4077
4078         case KEY_substr:
4079             LOP(OP_SUBSTR,XTERM);
4080
4081         case KEY_format:
4082         case KEY_sub:
4083           really_sub:
4084             s = skipspace(s);
4085
4086             if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4087                 char tmpbuf[sizeof PL_tokenbuf];
4088                 PL_expect = XBLOCK;
4089                 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4090                 if (strchr(tmpbuf, ':'))
4091                     sv_setpv(PL_subname, tmpbuf);
4092                 else {
4093                     sv_setsv(PL_subname,PL_curstname);
4094                     sv_catpvn(PL_subname,"::",2);
4095                     sv_catpvn(PL_subname,tmpbuf,len);
4096                 }
4097                 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4098                 s = skipspace(s);
4099             }
4100             else {
4101                 PL_expect = XTERMBLOCK;
4102                 sv_setpv(PL_subname,"?");
4103             }
4104
4105             if (tmp == KEY_format) {
4106                 s = skipspace(s);
4107                 if (*s == '=')
4108                     PL_lex_formbrack = PL_lex_brackets + 1;
4109                 OPERATOR(FORMAT);
4110             }
4111
4112             /* Look for a prototype */
4113             if (*s == '(') {
4114                 char *p;
4115
4116                 s = scan_str(s);
4117                 if (!s) {
4118                     if (PL_lex_stuff)
4119                         SvREFCNT_dec(PL_lex_stuff);
4120                     PL_lex_stuff = Nullsv;
4121                     croak("Prototype not terminated");
4122                 }
4123                 /* strip spaces */
4124                 d = SvPVX(PL_lex_stuff);
4125                 tmp = 0;
4126                 for (p = d; *p; ++p) {
4127                     if (!isSPACE(*p))
4128                         d[tmp++] = *p;
4129                 }
4130                 d[tmp] = '\0';
4131                 SvCUR(PL_lex_stuff) = tmp;
4132
4133                 PL_nexttoke++;
4134                 PL_nextval[1] = PL_nextval[0];
4135                 PL_nexttype[1] = PL_nexttype[0];
4136                 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4137                 PL_nexttype[0] = THING;
4138                 if (PL_nexttoke == 1) {
4139                     PL_lex_defer = PL_lex_state;
4140                     PL_lex_expect = PL_expect;
4141                     PL_lex_state = LEX_KNOWNEXT;
4142                 }
4143                 PL_lex_stuff = Nullsv;
4144             }
4145
4146             if (*SvPV(PL_subname,n_a) == '?') {
4147                 sv_setpv(PL_subname,"__ANON__");
4148                 TOKEN(ANONSUB);
4149             }
4150             PREBLOCK(SUB);
4151
4152         case KEY_system:
4153             set_csh();
4154             LOP(OP_SYSTEM,XREF);
4155
4156         case KEY_symlink:
4157             LOP(OP_SYMLINK,XTERM);
4158
4159         case KEY_syscall:
4160             LOP(OP_SYSCALL,XTERM);
4161
4162         case KEY_sysopen:
4163             LOP(OP_SYSOPEN,XTERM);
4164
4165         case KEY_sysseek:
4166             LOP(OP_SYSSEEK,XTERM);
4167
4168         case KEY_sysread:
4169             LOP(OP_SYSREAD,XTERM);
4170
4171         case KEY_syswrite:
4172             LOP(OP_SYSWRITE,XTERM);
4173
4174         case KEY_tr:
4175             s = scan_trans(s);
4176             TERM(sublex_start());
4177
4178         case KEY_tell:
4179             UNI(OP_TELL);
4180
4181         case KEY_telldir:
4182             UNI(OP_TELLDIR);
4183
4184         case KEY_tie:
4185             LOP(OP_TIE,XTERM);
4186
4187         case KEY_tied:
4188             UNI(OP_TIED);
4189
4190         case KEY_time:
4191             FUN0(OP_TIME);
4192
4193         case KEY_times:
4194             FUN0(OP_TMS);
4195
4196         case KEY_truncate:
4197             LOP(OP_TRUNCATE,XTERM);
4198
4199         case KEY_uc:
4200             UNI(OP_UC);
4201
4202         case KEY_ucfirst:
4203             UNI(OP_UCFIRST);
4204
4205         case KEY_untie:
4206             UNI(OP_UNTIE);
4207
4208         case KEY_until:
4209             yylval.ival = PL_curcop->cop_line;
4210             OPERATOR(UNTIL);
4211
4212         case KEY_unless:
4213             yylval.ival = PL_curcop->cop_line;
4214             OPERATOR(UNLESS);
4215
4216         case KEY_unlink:
4217             LOP(OP_UNLINK,XTERM);
4218
4219         case KEY_undef:
4220             UNI(OP_UNDEF);
4221
4222         case KEY_unpack:
4223             LOP(OP_UNPACK,XTERM);
4224
4225         case KEY_utime:
4226             LOP(OP_UTIME,XTERM);
4227
4228         case KEY_umask:
4229             if (ckWARN(WARN_OCTAL)) {
4230                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4231                 if (*d != '0' && isDIGIT(*d))
4232                     yywarn("umask: argument is missing initial 0");
4233             }
4234             UNI(OP_UMASK);
4235
4236         case KEY_unshift:
4237             LOP(OP_UNSHIFT,XTERM);
4238
4239         case KEY_use:
4240             if (PL_expect != XSTATE)
4241                 yyerror("\"use\" not allowed in expression");
4242             s = skipspace(s);
4243             if(isDIGIT(*s)) {
4244                 s = force_version(s);
4245                 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4246                     PL_nextval[PL_nexttoke].opval = Nullop;
4247                     force_next(WORD);
4248                 }
4249             }
4250             else {
4251                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4252                 s = force_version(s);
4253             }
4254             yylval.ival = 1;
4255             OPERATOR(USE);
4256
4257         case KEY_values:
4258             UNI(OP_VALUES);
4259
4260         case KEY_vec:
4261             PL_sawvec = TRUE;
4262             LOP(OP_VEC,XTERM);
4263
4264         case KEY_while:
4265             yylval.ival = PL_curcop->cop_line;
4266             OPERATOR(WHILE);
4267
4268         case KEY_warn:
4269             PL_hints |= HINT_BLOCK_SCOPE;
4270             LOP(OP_WARN,XTERM);
4271
4272         case KEY_wait:
4273             FUN0(OP_WAIT);
4274
4275         case KEY_waitpid:
4276             LOP(OP_WAITPID,XTERM);
4277
4278         case KEY_wantarray:
4279             FUN0(OP_WANTARRAY);
4280
4281         case KEY_write:
4282 #ifdef EBCDIC
4283         {
4284             static char ctl_l[2];
4285
4286             if (ctl_l[0] == '\0')
4287                 ctl_l[0] = toCTRL('L');
4288             gv_fetchpv(ctl_l,TRUE, SVt_PV);
4289         }
4290 #else
4291             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
4292 #endif
4293             UNI(OP_ENTERWRITE);
4294
4295         case KEY_x:
4296             if (PL_expect == XOPERATOR)
4297                 Mop(OP_REPEAT);
4298             check_uni();
4299             goto just_a_word;
4300
4301         case KEY_xor:
4302             yylval.ival = OP_XOR;
4303             OPERATOR(OROP);
4304
4305         case KEY_y:
4306             s = scan_trans(s);
4307             TERM(sublex_start());
4308         }
4309     }}
4310 }
4311
4312 I32
4313 keyword(register char *d, I32 len)
4314 {
4315     switch (*d) {
4316     case '_':
4317         if (d[1] == '_') {
4318             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
4319             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
4320             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
4321             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
4322             if (strEQ(d,"__END__"))             return KEY___END__;
4323         }
4324         break;
4325     case 'A':
4326         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
4327         break;
4328     case 'a':
4329         switch (len) {
4330         case 3:
4331             if (strEQ(d,"and"))                 return -KEY_and;
4332             if (strEQ(d,"abs"))                 return -KEY_abs;
4333             break;
4334         case 5:
4335             if (strEQ(d,"alarm"))               return -KEY_alarm;
4336             if (strEQ(d,"atan2"))               return -KEY_atan2;
4337             break;
4338         case 6:
4339             if (strEQ(d,"accept"))              return -KEY_accept;
4340             break;
4341         }
4342         break;
4343     case 'B':
4344         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
4345         break;
4346     case 'b':
4347         if (strEQ(d,"bless"))                   return -KEY_bless;
4348         if (strEQ(d,"bind"))                    return -KEY_bind;
4349         if (strEQ(d,"binmode"))                 return -KEY_binmode;
4350         break;
4351     case 'C':
4352         if (strEQ(d,"CORE"))                    return -KEY_CORE;
4353         break;
4354     case 'c':
4355         switch (len) {
4356         case 3:
4357             if (strEQ(d,"cmp"))                 return -KEY_cmp;
4358             if (strEQ(d,"chr"))                 return -KEY_chr;
4359             if (strEQ(d,"cos"))                 return -KEY_cos;
4360             break;
4361         case 4:
4362             if (strEQ(d,"chop"))                return KEY_chop;
4363             break;
4364         case 5:
4365             if (strEQ(d,"close"))               return -KEY_close;
4366             if (strEQ(d,"chdir"))               return -KEY_chdir;
4367             if (strEQ(d,"chomp"))               return KEY_chomp;
4368             if (strEQ(d,"chmod"))               return -KEY_chmod;
4369             if (strEQ(d,"chown"))               return -KEY_chown;
4370             if (strEQ(d,"crypt"))               return -KEY_crypt;
4371             break;
4372         case 6:
4373             if (strEQ(d,"chroot"))              return -KEY_chroot;
4374             if (strEQ(d,"caller"))              return -KEY_caller;
4375             break;
4376         case 7:
4377             if (strEQ(d,"connect"))             return -KEY_connect;
4378             break;
4379         case 8:
4380             if (strEQ(d,"closedir"))            return -KEY_closedir;
4381             if (strEQ(d,"continue"))            return -KEY_continue;
4382             break;
4383         }
4384         break;
4385     case 'D':
4386         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
4387         break;
4388     case 'd':
4389         switch (len) {
4390         case 2:
4391             if (strEQ(d,"do"))                  return KEY_do;
4392             break;
4393         case 3:
4394             if (strEQ(d,"die"))                 return -KEY_die;
4395             break;
4396         case 4:
4397             if (strEQ(d,"dump"))                return -KEY_dump;
4398             break;
4399         case 6:
4400             if (strEQ(d,"delete"))              return KEY_delete;
4401             break;
4402         case 7:
4403             if (strEQ(d,"defined"))             return KEY_defined;
4404             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
4405             break;
4406         case 8:
4407             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
4408             break;
4409         }
4410         break;
4411     case 'E':
4412         if (strEQ(d,"EQ")) { deprecate(d);      return -KEY_eq;}
4413         if (strEQ(d,"END"))                     return KEY_END;
4414         break;
4415     case 'e':
4416         switch (len) {
4417         case 2:
4418             if (strEQ(d,"eq"))                  return -KEY_eq;
4419             break;
4420         case 3:
4421             if (strEQ(d,"eof"))                 return -KEY_eof;
4422             if (strEQ(d,"exp"))                 return -KEY_exp;
4423             break;
4424         case 4:
4425             if (strEQ(d,"else"))                return KEY_else;
4426             if (strEQ(d,"exit"))                return -KEY_exit;
4427             if (strEQ(d,"eval"))                return KEY_eval;
4428             if (strEQ(d,"exec"))                return -KEY_exec;
4429             if (strEQ(d,"each"))                return KEY_each;
4430             break;
4431         case 5:
4432             if (strEQ(d,"elsif"))               return KEY_elsif;
4433             break;
4434         case 6:
4435             if (strEQ(d,"exists"))              return KEY_exists;
4436             if (strEQ(d,"elseif")) warn("elseif should be elsif");
4437             break;
4438         case 8:
4439             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
4440             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
4441             break;
4442         case 9:
4443             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
4444             break;
4445         case 10:
4446             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
4447             if (strEQ(d,"endservent"))          return -KEY_endservent;
4448             break;
4449         case 11:
4450             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
4451             break;
4452         }
4453         break;
4454     case 'f':
4455         switch (len) {
4456         case 3:
4457             if (strEQ(d,"for"))                 return KEY_for;
4458             break;
4459         case 4:
4460             if (strEQ(d,"fork"))                return -KEY_fork;