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