toke.c

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