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                         CV *cv;
3162                         if ((cv = GvCV(gv)) && SvPOK(cv))
3163                             PL_last_proto = SvPV((SV*)cv, PL_na);
3164                         for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
3165                         if (*d == ')' && (sv = cv_const_sv(cv))) {
3166                             s = d + 1;
3167                             goto its_constant;
3168                         }
3169                     }
3170                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3171                     PL_expect = XOPERATOR;
3172                     force_next(WORD);
3173                     yylval.ival = 0;
3174                     PL_last_lop_op = OP_ENTERSUB;
3175                     TOKEN('&');
3176                 }
3177
3178                 /* If followed by var or block, call it a method (unless sub) */
3179
3180                 if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) {
3181                     PL_last_lop = PL_oldbufptr;
3182                     PL_last_lop_op = OP_METHOD;
3183                     PREBLOCK(METHOD);
3184                 }
3185
3186                 /* If followed by a bareword, see if it looks like indir obj. */
3187
3188                 if ((isIDFIRST_lazy(s) || *s == '$') && (tmp = intuit_method(s,gv)))
3189                     return tmp;
3190
3191                 /* Not a method, so call it a subroutine (if defined) */
3192
3193                 if (gv && GvCVu(gv)) {
3194                     CV* cv;
3195                     if (lastchar == '-')
3196                         warn("Ambiguous use of -%s resolved as -&%s()",
3197                                 PL_tokenbuf, PL_tokenbuf);
3198                     PL_last_lop = PL_oldbufptr;
3199                     PL_last_lop_op = OP_ENTERSUB;
3200                     /* Check for a constant sub */
3201                     cv = GvCV(gv);
3202                     if ((sv = cv_const_sv(cv))) {
3203                   its_constant:
3204                         SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv);
3205                         ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv);
3206                         yylval.opval->op_private = 0;
3207                         TOKEN(WORD);
3208                     }
3209
3210                     /* Resolve to GV now. */
3211                     op_free(yylval.opval);
3212                     yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
3213                     PL_last_lop_op = OP_ENTERSUB;
3214                     /* Is there a prototype? */
3215                     if (SvPOK(cv)) {
3216                         STRLEN len;
3217                         PL_last_proto = SvPV((SV*)cv, len);
3218                         if (!len)
3219                             TERM(FUNC0SUB);
3220                         if (strEQ(PL_last_proto, "$"))
3221                             OPERATOR(UNIOPSUB);
3222                         if (*PL_last_proto == '&' && *s == '{') {
3223                             sv_setpv(PL_subname,"__ANON__");
3224                             PREBLOCK(LSTOPSUB);
3225                         }
3226                     } else
3227                         PL_last_proto = NULL;
3228                     PL_nextval[PL_nexttoke].opval = yylval.opval;
3229                     PL_expect = XTERM;
3230                     force_next(WORD);
3231                     TOKEN(NOAMP);
3232                 }
3233
3234                 if (PL_hints & HINT_STRICT_SUBS &&
3235                     lastchar != '-' &&
3236                     strnNE(s,"->",2) &&
3237                     PL_last_lop_op != OP_TRUNCATE &&  /* S/F prototype in opcode.pl */
3238                     PL_last_lop_op != OP_ACCEPT &&
3239                     PL_last_lop_op != OP_PIPE_OP &&
3240                     PL_last_lop_op != OP_SOCKPAIR &&
3241                     !(PL_last_lop_op == OP_ENTERSUB
3242                          && PL_last_proto
3243                          && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
3244                 {
3245                     warn(
3246                      "Bareword \"%s\" not allowed while \"strict subs\" in use",
3247                         PL_tokenbuf);
3248                     ++PL_error_count;
3249                 }
3250
3251                 /* Call it a bare word */
3252
3253             bareword:
3254                 if (ckWARN(WARN_RESERVED)) {
3255                     if (lastchar != '-') {
3256                         for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
3257                         if (!*d)
3258                             warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
3259                     }
3260                 }
3261
3262             safe_bareword:
3263                 if (lastchar && strchr("*%&", lastchar)) {
3264                     warn("Operator or semicolon missing before %c%s",
3265                         lastchar, PL_tokenbuf);
3266                     warn("Ambiguous use of %c resolved as operator %c",
3267                         lastchar, lastchar);
3268                 }
3269                 TOKEN(WORD);
3270             }
3271
3272         case KEY___FILE__:
3273             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3274                                         newSVsv(GvSV(PL_curcop->cop_filegv)));
3275             TERM(THING);
3276
3277         case KEY___LINE__:
3278             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3279                                     newSVpvf("%ld", (long)PL_curcop->cop_line));
3280             TERM(THING);
3281
3282         case KEY___PACKAGE__:
3283             yylval.opval = (OP*)newSVOP(OP_CONST, 0,
3284                                         (PL_curstash
3285                                          ? newSVsv(PL_curstname)
3286                                          : &PL_sv_undef));
3287             TERM(THING);
3288
3289         case KEY___DATA__:
3290         case KEY___END__: {
3291             GV *gv;
3292
3293             /*SUPPRESS 560*/
3294             if (PL_rsfp && (!PL_in_eval || PL_tokenbuf[2] == 'D')) {
3295                 char *pname = "main";
3296                 if (PL_tokenbuf[2] == 'D')
3297                     pname = HvNAME(PL_curstash ? PL_curstash : PL_defstash);
3298                 gv = gv_fetchpv(form("%s::DATA", pname), TRUE, SVt_PVIO);
3299                 GvMULTI_on(gv);
3300                 if (!GvIO(gv))
3301                     GvIOp(gv) = newIO();
3302                 IoIFP(GvIOp(gv)) = PL_rsfp;
3303 #if defined(HAS_FCNTL) && defined(F_SETFD)
3304                 {
3305                     int fd = PerlIO_fileno(PL_rsfp);
3306                     fcntl(fd,F_SETFD,fd >= 3);
3307                 }
3308 #endif
3309                 /* Mark this internal pseudo-handle as clean */
3310                 IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
3311                 if (PL_preprocess)
3312                     IoTYPE(GvIOp(gv)) = '|';
3313                 else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
3314                     IoTYPE(GvIOp(gv)) = '-';
3315                 else
3316                     IoTYPE(GvIOp(gv)) = '<';
3317                 PL_rsfp = Nullfp;
3318             }
3319             goto fake_eof;
3320         }
3321
3322         case KEY_AUTOLOAD:
3323         case KEY_DESTROY:
3324         case KEY_BEGIN:
3325         case KEY_END:
3326         case KEY_INIT:
3327             if (PL_expect == XSTATE) {
3328                 s = PL_bufptr;
3329                 goto really_sub;
3330             }
3331             goto just_a_word;
3332
3333         case KEY_CORE:
3334             if (*s == ':' && s[1] == ':') {
3335                 s += 2;
3336                 d = s;
3337                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
3338                 tmp = keyword(PL_tokenbuf, len);
3339                 if (tmp < 0)
3340                     tmp = -tmp;
3341                 goto reserved_word;
3342             }
3343             goto just_a_word;
3344
3345         case KEY_abs:
3346             UNI(OP_ABS);
3347
3348         case KEY_alarm:
3349             UNI(OP_ALARM);
3350
3351         case KEY_accept:
3352             LOP(OP_ACCEPT,XTERM);
3353
3354         case KEY_and:
3355             OPERATOR(ANDOP);
3356
3357         case KEY_atan2:
3358             LOP(OP_ATAN2,XTERM);
3359
3360         case KEY_bind:
3361             LOP(OP_BIND,XTERM);
3362
3363         case KEY_binmode:
3364             UNI(OP_BINMODE);
3365
3366         case KEY_bless:
3367             LOP(OP_BLESS,XTERM);
3368
3369         case KEY_chop:
3370             UNI(OP_CHOP);
3371
3372         case KEY_continue:
3373             PREBLOCK(CONTINUE);
3374
3375         case KEY_chdir:
3376             (void)gv_fetchpv("ENV",TRUE, SVt_PVHV);     /* may use HOME */
3377             UNI(OP_CHDIR);
3378
3379         case KEY_close:
3380             UNI(OP_CLOSE);
3381
3382         case KEY_closedir:
3383             UNI(OP_CLOSEDIR);
3384
3385         case KEY_cmp:
3386             Eop(OP_SCMP);
3387
3388         case KEY_caller:
3389             UNI(OP_CALLER);
3390
3391         case KEY_crypt:
3392 #ifdef FCRYPT
3393             if (!PL_cryptseen++)
3394                 init_des();
3395 #endif
3396             LOP(OP_CRYPT,XTERM);
3397
3398         case KEY_chmod:
3399             if (ckWARN(WARN_OCTAL)) {
3400                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
3401                 if (*d != '0' && isDIGIT(*d))
3402                     yywarn("chmod: mode argument is missing initial 0");
3403             }
3404             LOP(OP_CHMOD,XTERM);
3405
3406         case KEY_chown:
3407             LOP(OP_CHOWN,XTERM);
3408
3409         case KEY_connect:
3410             LOP(OP_CONNECT,XTERM);
3411
3412         case KEY_chr:
3413             UNI(OP_CHR);
3414
3415         case KEY_cos:
3416             UNI(OP_COS);
3417
3418         case KEY_chroot:
3419             UNI(OP_CHROOT);
3420
3421         case KEY_do:
3422             s = skipspace(s);
3423             if (*s == '{')
3424                 PRETERMBLOCK(DO);
3425             if (*s != '\'')
3426                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
3427             OPERATOR(DO);
3428
3429         case KEY_die:
3430             PL_hints |= HINT_BLOCK_SCOPE;
3431             LOP(OP_DIE,XTERM);
3432
3433         case KEY_defined:
3434             UNI(OP_DEFINED);
3435
3436         case KEY_delete:
3437             UNI(OP_DELETE);
3438
3439         case KEY_dbmopen:
3440             gv_fetchpv("AnyDBM_File::ISA", GV_ADDMULTI, SVt_PVAV);
3441             LOP(OP_DBMOPEN,XTERM);
3442
3443         case KEY_dbmclose:
3444             UNI(OP_DBMCLOSE);
3445
3446         case KEY_dump:
3447             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3448             LOOPX(OP_DUMP);
3449
3450         case KEY_else:
3451             PREBLOCK(ELSE);
3452
3453         case KEY_elsif:
3454             yylval.ival = PL_curcop->cop_line;
3455             OPERATOR(ELSIF);
3456
3457         case KEY_eq:
3458             Eop(OP_SEQ);
3459
3460         case KEY_exists:
3461             UNI(OP_EXISTS);
3462
3463         case KEY_exit:
3464             UNI(OP_EXIT);
3465
3466         case KEY_eval:
3467             s = skipspace(s);
3468             PL_expect = (*s == '{') ? XTERMBLOCK : XTERM;
3469             UNIBRACK(OP_ENTEREVAL);
3470
3471         case KEY_eof:
3472             UNI(OP_EOF);
3473
3474         case KEY_exp:
3475             UNI(OP_EXP);
3476
3477         case KEY_each:
3478             UNI(OP_EACH);
3479
3480         case KEY_exec:
3481             set_csh();
3482             LOP(OP_EXEC,XREF);
3483
3484         case KEY_endhostent:
3485             FUN0(OP_EHOSTENT);
3486
3487         case KEY_endnetent:
3488             FUN0(OP_ENETENT);
3489
3490         case KEY_endservent:
3491             FUN0(OP_ESERVENT);
3492
3493         case KEY_endprotoent:
3494             FUN0(OP_EPROTOENT);
3495
3496         case KEY_endpwent:
3497             FUN0(OP_EPWENT);
3498
3499         case KEY_endgrent:
3500             FUN0(OP_EGRENT);
3501
3502         case KEY_for:
3503         case KEY_foreach:
3504             yylval.ival = PL_curcop->cop_line;
3505             s = skipspace(s);
3506             if (PL_expect == XSTATE && isIDFIRST_lazy(s)) {
3507                 char *p = s;
3508                 if ((PL_bufend - p) >= 3 &&
3509                     strnEQ(p, "my", 2) && isSPACE(*(p + 2)))
3510                     p += 2;
3511                 p = skipspace(p);
3512                 if (isIDFIRST_lazy(p))
3513                     croak("Missing $ on loop variable");
3514             }
3515             OPERATOR(FOR);
3516
3517         case KEY_formline:
3518             LOP(OP_FORMLINE,XTERM);
3519
3520         case KEY_fork:
3521             FUN0(OP_FORK);
3522
3523         case KEY_fcntl:
3524             LOP(OP_FCNTL,XTERM);
3525
3526         case KEY_fileno:
3527             UNI(OP_FILENO);
3528
3529         case KEY_flock:
3530             LOP(OP_FLOCK,XTERM);
3531
3532         case KEY_gt:
3533             Rop(OP_SGT);
3534
3535         case KEY_ge:
3536             Rop(OP_SGE);
3537
3538         case KEY_grep:
3539             LOP(OP_GREPSTART, *s == '(' ? XTERM : XREF);
3540
3541         case KEY_goto:
3542             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3543             LOOPX(OP_GOTO);
3544
3545         case KEY_gmtime:
3546             UNI(OP_GMTIME);
3547
3548         case KEY_getc:
3549             UNI(OP_GETC);
3550
3551         case KEY_getppid:
3552             FUN0(OP_GETPPID);
3553
3554         case KEY_getpgrp:
3555             UNI(OP_GETPGRP);
3556
3557         case KEY_getpriority:
3558             LOP(OP_GETPRIORITY,XTERM);
3559
3560         case KEY_getprotobyname:
3561             UNI(OP_GPBYNAME);
3562
3563         case KEY_getprotobynumber:
3564             LOP(OP_GPBYNUMBER,XTERM);
3565
3566         case KEY_getprotoent:
3567             FUN0(OP_GPROTOENT);
3568
3569         case KEY_getpwent:
3570             FUN0(OP_GPWENT);
3571
3572         case KEY_getpwnam:
3573             UNI(OP_GPWNAM);
3574
3575         case KEY_getpwuid:
3576             UNI(OP_GPWUID);
3577
3578         case KEY_getpeername:
3579             UNI(OP_GETPEERNAME);
3580
3581         case KEY_gethostbyname:
3582             UNI(OP_GHBYNAME);
3583
3584         case KEY_gethostbyaddr:
3585             LOP(OP_GHBYADDR,XTERM);
3586
3587         case KEY_gethostent:
3588             FUN0(OP_GHOSTENT);
3589
3590         case KEY_getnetbyname:
3591             UNI(OP_GNBYNAME);
3592
3593         case KEY_getnetbyaddr:
3594             LOP(OP_GNBYADDR,XTERM);
3595
3596         case KEY_getnetent:
3597             FUN0(OP_GNETENT);
3598
3599         case KEY_getservbyname:
3600             LOP(OP_GSBYNAME,XTERM);
3601
3602         case KEY_getservbyport:
3603             LOP(OP_GSBYPORT,XTERM);
3604
3605         case KEY_getservent:
3606             FUN0(OP_GSERVENT);
3607
3608         case KEY_getsockname:
3609             UNI(OP_GETSOCKNAME);
3610
3611         case KEY_getsockopt:
3612             LOP(OP_GSOCKOPT,XTERM);
3613
3614         case KEY_getgrent:
3615             FUN0(OP_GGRENT);
3616
3617         case KEY_getgrnam:
3618             UNI(OP_GGRNAM);
3619
3620         case KEY_getgrgid:
3621             UNI(OP_GGRGID);
3622
3623         case KEY_getlogin:
3624             FUN0(OP_GETLOGIN);
3625
3626         case KEY_glob:
3627             set_csh();
3628             LOP(OP_GLOB,XTERM);
3629
3630         case KEY_hex:
3631             UNI(OP_HEX);
3632
3633         case KEY_if:
3634             yylval.ival = PL_curcop->cop_line;
3635             OPERATOR(IF);
3636
3637         case KEY_index:
3638             LOP(OP_INDEX,XTERM);
3639
3640         case KEY_int:
3641             UNI(OP_INT);
3642
3643         case KEY_ioctl:
3644             LOP(OP_IOCTL,XTERM);
3645
3646         case KEY_join:
3647             LOP(OP_JOIN,XTERM);
3648
3649         case KEY_keys:
3650             UNI(OP_KEYS);
3651
3652         case KEY_kill:
3653             LOP(OP_KILL,XTERM);
3654
3655         case KEY_last:
3656             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3657             LOOPX(OP_LAST);
3658
3659         case KEY_lc:
3660             UNI(OP_LC);
3661
3662         case KEY_lcfirst:
3663             UNI(OP_LCFIRST);
3664
3665         case KEY_local:
3666             OPERATOR(LOCAL);
3667
3668         case KEY_length:
3669             UNI(OP_LENGTH);
3670
3671         case KEY_lt:
3672             Rop(OP_SLT);
3673
3674         case KEY_le:
3675             Rop(OP_SLE);
3676
3677         case KEY_localtime:
3678             UNI(OP_LOCALTIME);
3679
3680         case KEY_log:
3681             UNI(OP_LOG);
3682
3683         case KEY_link:
3684             LOP(OP_LINK,XTERM);
3685
3686         case KEY_listen:
3687             LOP(OP_LISTEN,XTERM);
3688
3689         case KEY_lock:
3690             UNI(OP_LOCK);
3691
3692         case KEY_lstat:
3693             UNI(OP_LSTAT);
3694
3695         case KEY_m:
3696             s = scan_pat(s,OP_MATCH);
3697             TERM(sublex_start());
3698
3699         case KEY_map:
3700             LOP(OP_MAPSTART, XREF);
3701
3702         case KEY_mkdir:
3703             LOP(OP_MKDIR,XTERM);
3704
3705         case KEY_msgctl:
3706             LOP(OP_MSGCTL,XTERM);
3707
3708         case KEY_msgget:
3709             LOP(OP_MSGGET,XTERM);
3710
3711         case KEY_msgrcv:
3712             LOP(OP_MSGRCV,XTERM);
3713
3714         case KEY_msgsnd:
3715             LOP(OP_MSGSND,XTERM);
3716
3717         case KEY_my:
3718             PL_in_my = TRUE;
3719             s = skipspace(s);
3720             if (isIDFIRST_lazy(s)) {
3721                 s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
3722                 PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
3723                 if (!PL_in_my_stash) {
3724                     char tmpbuf[1024];
3725                     PL_bufptr = s;
3726                     sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf);
3727                     yyerror(tmpbuf);
3728                 }
3729             }
3730             OPERATOR(MY);
3731
3732         case KEY_next:
3733             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3734             LOOPX(OP_NEXT);
3735
3736         case KEY_ne:
3737             Eop(OP_SNE);
3738
3739         case KEY_no:
3740             if (PL_expect != XSTATE)
3741                 yyerror("\"no\" not allowed in expression");
3742             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3743             s = force_version(s);
3744             yylval.ival = 0;
3745             OPERATOR(USE);
3746
3747         case KEY_not:
3748             OPERATOR(NOTOP);
3749
3750         case KEY_open:
3751             s = skipspace(s);
3752             if (isIDFIRST_lazy(s)) {
3753                 char *t;
3754                 for (d = s; isALNUM_lazy(d); d++) ;
3755                 t = skipspace(d);
3756                 if (strchr("|&*+-=!?:.", *t))
3757                     warn("Precedence problem: open %.*s should be open(%.*s)",
3758                         d-s,s, d-s,s);
3759             }
3760             LOP(OP_OPEN,XTERM);
3761
3762         case KEY_or:
3763             yylval.ival = OP_OR;
3764             OPERATOR(OROP);
3765
3766         case KEY_ord:
3767             UNI(OP_ORD);
3768
3769         case KEY_oct:
3770             UNI(OP_OCT);
3771
3772         case KEY_opendir:
3773             LOP(OP_OPEN_DIR,XTERM);
3774
3775         case KEY_print:
3776             checkcomma(s,PL_tokenbuf,"filehandle");
3777             LOP(OP_PRINT,XREF);
3778
3779         case KEY_printf:
3780             checkcomma(s,PL_tokenbuf,"filehandle");
3781             LOP(OP_PRTF,XREF);
3782
3783         case KEY_prototype:
3784             UNI(OP_PROTOTYPE);
3785
3786         case KEY_push:
3787             LOP(OP_PUSH,XTERM);
3788
3789         case KEY_pop:
3790             UNI(OP_POP);
3791
3792         case KEY_pos:
3793             UNI(OP_POS);
3794
3795         case KEY_pack:
3796             LOP(OP_PACK,XTERM);
3797
3798         case KEY_package:
3799             s = force_word(s,WORD,FALSE,TRUE,FALSE);
3800             OPERATOR(PACKAGE);
3801
3802         case KEY_pipe:
3803             LOP(OP_PIPE_OP,XTERM);
3804
3805         case KEY_q:
3806             s = scan_str(s);
3807             if (!s)
3808                 missingterm((char*)0);
3809             yylval.ival = OP_CONST;
3810             TERM(sublex_start());
3811
3812         case KEY_quotemeta:
3813             UNI(OP_QUOTEMETA);
3814
3815         case KEY_qw:
3816             s = scan_str(s);
3817             if (!s)
3818                 missingterm((char*)0);
3819             if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
3820                 d = SvPV_force(PL_lex_stuff, len);
3821                 for (; len; --len, ++d) {
3822                     if (*d == ',') {
3823                         warner(WARN_SYNTAX,
3824                             "Possible attempt to separate words with commas");
3825                         break;
3826                     }
3827                     if (*d == '#') {
3828                         warner(WARN_SYNTAX,
3829                             "Possible attempt to put comments in qw() list");
3830                         break;
3831                     }
3832                 }
3833             }
3834             force_next(')');
3835             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, tokeq(PL_lex_stuff));
3836             PL_lex_stuff = Nullsv;
3837             force_next(THING);
3838             force_next(',');
3839             PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(" ",1));
3840             force_next(THING);
3841             force_next('(');
3842             yylval.ival = OP_SPLIT;
3843             CLINE;
3844             PL_expect = XTERM;
3845             PL_bufptr = s;
3846             PL_last_lop = PL_oldbufptr;
3847             PL_last_lop_op = OP_SPLIT;
3848             return FUNC;
3849
3850         case KEY_qq:
3851             s = scan_str(s);
3852             if (!s)
3853                 missingterm((char*)0);
3854             yylval.ival = OP_STRINGIFY;
3855             if (SvIVX(PL_lex_stuff) == '\'')
3856                 SvIVX(PL_lex_stuff) = 0;        /* qq'$foo' should intepolate */
3857             TERM(sublex_start());
3858
3859         case KEY_qr:
3860             s = scan_pat(s,OP_QR);
3861             TERM(sublex_start());
3862
3863         case KEY_qx:
3864             s = scan_str(s);
3865             if (!s)
3866                 missingterm((char*)0);
3867             yylval.ival = OP_BACKTICK;
3868             set_csh();
3869             TERM(sublex_start());
3870
3871         case KEY_return:
3872             OLDLOP(OP_RETURN);
3873
3874         case KEY_require:
3875             *PL_tokenbuf = '\0';
3876             s = force_word(s,WORD,TRUE,TRUE,FALSE);
3877             if (isIDFIRST_lazy(PL_tokenbuf))
3878                 gv_stashpvn(PL_tokenbuf, strlen(PL_tokenbuf), TRUE);
3879             else if (*s == '<')
3880                 yyerror("<> should be quotes");
3881             UNI(OP_REQUIRE);
3882
3883         case KEY_reset:
3884             UNI(OP_RESET);
3885
3886         case KEY_redo:
3887             s = force_word(s,WORD,TRUE,FALSE,FALSE);
3888             LOOPX(OP_REDO);
3889
3890         case KEY_rename:
3891             LOP(OP_RENAME,XTERM);
3892
3893         case KEY_rand:
3894             UNI(OP_RAND);
3895
3896         case KEY_rmdir:
3897             UNI(OP_RMDIR);
3898
3899         case KEY_rindex:
3900             LOP(OP_RINDEX,XTERM);
3901
3902         case KEY_read:
3903             LOP(OP_READ,XTERM);
3904
3905         case KEY_readdir:
3906             UNI(OP_READDIR);
3907
3908         case KEY_readline:
3909             set_csh();
3910             UNI(OP_READLINE);
3911
3912         case KEY_readpipe:
3913             set_csh();
3914             UNI(OP_BACKTICK);
3915
3916         case KEY_rewinddir:
3917             UNI(OP_REWINDDIR);
3918
3919         case KEY_recv:
3920             LOP(OP_RECV,XTERM);
3921
3922         case KEY_reverse:
3923             LOP(OP_REVERSE,XTERM);
3924
3925         case KEY_readlink:
3926             UNI(OP_READLINK);
3927
3928         case KEY_ref:
3929             UNI(OP_REF);
3930
3931         case KEY_s:
3932             s = scan_subst(s);
3933             if (yylval.opval)
3934                 TERM(sublex_start());
3935             else
3936                 TOKEN(1);       /* force error */
3937
3938         case KEY_chomp:
3939             UNI(OP_CHOMP);
3940
3941         case KEY_scalar:
3942             UNI(OP_SCALAR);
3943
3944         case KEY_select:
3945             LOP(OP_SELECT,XTERM);
3946
3947         case KEY_seek:
3948             LOP(OP_SEEK,XTERM);
3949
3950         case KEY_semctl:
3951             LOP(OP_SEMCTL,XTERM);
3952
3953         case KEY_semget:
3954             LOP(OP_SEMGET,XTERM);
3955
3956         case KEY_semop:
3957             LOP(OP_SEMOP,XTERM);
3958
3959         case KEY_send:
3960             LOP(OP_SEND,XTERM);
3961
3962         case KEY_setpgrp:
3963             LOP(OP_SETPGRP,XTERM);
3964
3965         case KEY_setpriority:
3966             LOP(OP_SETPRIORITY,XTERM);
3967
3968         case KEY_sethostent:
3969             UNI(OP_SHOSTENT);
3970
3971         case KEY_setnetent:
3972             UNI(OP_SNETENT);
3973
3974         case KEY_setservent:
3975             UNI(OP_SSERVENT);
3976
3977         case KEY_setprotoent:
3978             UNI(OP_SPROTOENT);
3979
3980         case KEY_setpwent:
3981             FUN0(OP_SPWENT);
3982
3983         case KEY_setgrent:
3984             FUN0(OP_SGRENT);
3985
3986         case KEY_seekdir:
3987             LOP(OP_SEEKDIR,XTERM);
3988
3989         case KEY_setsockopt:
3990             LOP(OP_SSOCKOPT,XTERM);
3991
3992         case KEY_shift:
3993             UNI(OP_SHIFT);
3994
3995         case KEY_shmctl:
3996             LOP(OP_SHMCTL,XTERM);
3997
3998         case KEY_shmget:
3999             LOP(OP_SHMGET,XTERM);
4000
4001         case KEY_shmread:
4002             LOP(OP_SHMREAD,XTERM);
4003
4004         case KEY_shmwrite:
4005             LOP(OP_SHMWRITE,XTERM);
4006
4007         case KEY_shutdown:
4008             LOP(OP_SHUTDOWN,XTERM);
4009
4010         case KEY_sin:
4011             UNI(OP_SIN);
4012
4013         case KEY_sleep:
4014             UNI(OP_SLEEP);
4015
4016         case KEY_socket:
4017             LOP(OP_SOCKET,XTERM);
4018
4019         case KEY_socketpair:
4020             LOP(OP_SOCKPAIR,XTERM);
4021
4022         case KEY_sort:
4023             checkcomma(s,PL_tokenbuf,"subroutine name");
4024             s = skipspace(s);
4025             if (*s == ';' || *s == ')')         /* probably a close */
4026                 croak("sort is now a reserved word");
4027             PL_expect = XTERM;
4028             s = force_word(s,WORD,TRUE,TRUE,FALSE);
4029             LOP(OP_SORT,XREF);
4030
4031         case KEY_split:
4032             LOP(OP_SPLIT,XTERM);
4033
4034         case KEY_sprintf:
4035             LOP(OP_SPRINTF,XTERM);
4036
4037         case KEY_splice:
4038             LOP(OP_SPLICE,XTERM);
4039
4040         case KEY_sqrt:
4041             UNI(OP_SQRT);
4042
4043         case KEY_srand:
4044             UNI(OP_SRAND);
4045
4046         case KEY_stat:
4047             UNI(OP_STAT);
4048
4049         case KEY_study:
4050             PL_sawstudy++;
4051             UNI(OP_STUDY);
4052
4053         case KEY_substr:
4054             LOP(OP_SUBSTR,XTERM);
4055
4056         case KEY_format:
4057         case KEY_sub:
4058           really_sub:
4059             s = skipspace(s);
4060
4061             if (isIDFIRST_lazy(s) || *s == '\'' || *s == ':') {
4062                 char tmpbuf[sizeof PL_tokenbuf];
4063                 PL_expect = XBLOCK;
4064                 d = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len);
4065                 if (strchr(tmpbuf, ':'))
4066                     sv_setpv(PL_subname, tmpbuf);
4067                 else {
4068                     sv_setsv(PL_subname,PL_curstname);
4069                     sv_catpvn(PL_subname,"::",2);
4070                     sv_catpvn(PL_subname,tmpbuf,len);
4071                 }
4072                 s = force_word(s,WORD,FALSE,TRUE,TRUE);
4073                 s = skipspace(s);
4074             }
4075             else {
4076                 PL_expect = XTERMBLOCK;
4077                 sv_setpv(PL_subname,"?");
4078             }
4079
4080             if (tmp == KEY_format) {
4081                 s = skipspace(s);
4082                 if (*s == '=')
4083                     PL_lex_formbrack = PL_lex_brackets + 1;
4084                 OPERATOR(FORMAT);
4085             }
4086
4087             /* Look for a prototype */
4088             if (*s == '(') {
4089                 char *p;
4090
4091                 s = scan_str(s);
4092                 if (!s) {
4093                     if (PL_lex_stuff)
4094                         SvREFCNT_dec(PL_lex_stuff);
4095                     PL_lex_stuff = Nullsv;
4096                     croak("Prototype not terminated");
4097                 }
4098                 /* strip spaces */
4099                 d = SvPVX(PL_lex_stuff);
4100                 tmp = 0;
4101                 for (p = d; *p; ++p) {
4102                     if (!isSPACE(*p))
4103                         d[tmp++] = *p;
4104                 }
4105                 d[tmp] = '\0';
4106                 SvCUR(PL_lex_stuff) = tmp;
4107
4108                 PL_nexttoke++;
4109                 PL_nextval[1] = PL_nextval[0];
4110                 PL_nexttype[1] = PL_nexttype[0];
4111                 PL_nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, PL_lex_stuff);
4112                 PL_nexttype[0] = THING;
4113                 if (PL_nexttoke == 1) {
4114                     PL_lex_defer = PL_lex_state;
4115                     PL_lex_expect = PL_expect;
4116                     PL_lex_state = LEX_KNOWNEXT;
4117                 }
4118                 PL_lex_stuff = Nullsv;
4119             }
4120
4121             if (*SvPV(PL_subname,PL_na) == '?') {
4122                 sv_setpv(PL_subname,"__ANON__");
4123                 TOKEN(ANONSUB);
4124             }
4125             PREBLOCK(SUB);
4126
4127         case KEY_system:
4128             set_csh();
4129             LOP(OP_SYSTEM,XREF);
4130
4131         case KEY_symlink:
4132             LOP(OP_SYMLINK,XTERM);
4133
4134         case KEY_syscall:
4135             LOP(OP_SYSCALL,XTERM);
4136
4137         case KEY_sysopen:
4138             LOP(OP_SYSOPEN,XTERM);
4139
4140         case KEY_sysseek:
4141             LOP(OP_SYSSEEK,XTERM);
4142
4143         case KEY_sysread:
4144             LOP(OP_SYSREAD,XTERM);
4145
4146         case KEY_syswrite:
4147             LOP(OP_SYSWRITE,XTERM);
4148
4149         case KEY_tr:
4150             s = scan_trans(s);
4151             TERM(sublex_start());
4152
4153         case KEY_tell:
4154             UNI(OP_TELL);
4155
4156         case KEY_telldir:
4157             UNI(OP_TELLDIR);
4158
4159         case KEY_tie:
4160             LOP(OP_TIE,XTERM);
4161
4162         case KEY_tied:
4163             UNI(OP_TIED);
4164
4165         case KEY_time:
4166             FUN0(OP_TIME);
4167
4168         case KEY_times:
4169             FUN0(OP_TMS);
4170
4171         case KEY_truncate:
4172             LOP(OP_TRUNCATE,XTERM);
4173
4174         case KEY_uc:
4175             UNI(OP_UC);
4176
4177         case KEY_ucfirst:
4178             UNI(OP_UCFIRST);
4179
4180         case KEY_untie:
4181             UNI(OP_UNTIE);
4182
4183         case KEY_until:
4184             yylval.ival = PL_curcop->cop_line;
4185             OPERATOR(UNTIL);
4186
4187         case KEY_unless:
4188             yylval.ival = PL_curcop->cop_line;
4189             OPERATOR(UNLESS);
4190
4191         case KEY_unlink:
4192             LOP(OP_UNLINK,XTERM);
4193
4194         case KEY_undef:
4195             UNI(OP_UNDEF);
4196
4197         case KEY_unpack:
4198             LOP(OP_UNPACK,XTERM);
4199
4200         case KEY_utime:
4201             LOP(OP_UTIME,XTERM);
4202
4203         case KEY_umask:
4204             if (ckWARN(WARN_OCTAL)) {
4205                 for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
4206                 if (*d != '0' && isDIGIT(*d))
4207                     yywarn("umask: argument is missing initial 0");
4208             }
4209             UNI(OP_UMASK);
4210
4211         case KEY_unshift:
4212             LOP(OP_UNSHIFT,XTERM);
4213
4214         case KEY_use:
4215             if (PL_expect != XSTATE)
4216                 yyerror("\"use\" not allowed in expression");
4217             s = skipspace(s);
4218             if(isDIGIT(*s)) {
4219                 s = force_version(s);
4220                 if(*s == ';' || (s = skipspace(s), *s == ';')) {
4221                     PL_nextval[PL_nexttoke].opval = Nullop;
4222                     force_next(WORD);
4223                 }
4224             }
4225             else {
4226                 s = force_word(s,WORD,FALSE,TRUE,FALSE);
4227                 s = force_version(s);
4228             }
4229             yylval.ival = 1;
4230             OPERATOR(USE);
4231
4232         case KEY_values:
4233             UNI(OP_VALUES);
4234
4235         case KEY_vec:
4236             PL_sawvec = TRUE;
4237             LOP(OP_VEC,XTERM);
4238
4239         case KEY_while:
4240             yylval.ival = PL_curcop->cop_line;
4241             OPERATOR(WHILE);
4242
4243         case KEY_warn:
4244             PL_hints |= HINT_BLOCK_SCOPE;
4245             LOP(OP_WARN,XTERM);
4246
4247         case KEY_wait:
4248             FUN0(OP_WAIT);
4249
4250         case KEY_waitpid:
4251             LOP(OP_WAITPID,XTERM);
4252
4253         case KEY_wantarray:
4254             FUN0(OP_WANTARRAY);
4255
4256         case KEY_write:
4257 #ifdef EBCDIC
4258         {
4259             static char ctl_l[2];
4260
4261             if (ctl_l[0] == '\0')
4262                 ctl_l[0] = toCTRL('L');
4263             gv_fetchpv(ctl_l,TRUE, SVt_PV);
4264         }
4265 #else
4266             gv_fetchpv("\f",TRUE, SVt_PV);      /* Make sure $^L is defined */
4267 #endif
4268             UNI(OP_ENTERWRITE);
4269
4270         case KEY_x:
4271             if (PL_expect == XOPERATOR)
4272                 Mop(OP_REPEAT);
4273             check_uni();
4274             goto just_a_word;
4275
4276         case KEY_xor:
4277             yylval.ival = OP_XOR;
4278             OPERATOR(OROP);
4279
4280         case KEY_y:
4281             s = scan_trans(s);
4282             TERM(sublex_start());
4283         }
4284     }}
4285 }
4286
4287 I32
4288 keyword(register char *d, I32 len)
4289 {
4290     switch (*d) {
4291     case '_':
4292         if (d[1] == '_') {
4293             if (strEQ(d,"__FILE__"))            return -KEY___FILE__;
4294             if (strEQ(d,"__LINE__"))            return -KEY___LINE__;
4295             if (strEQ(d,"__PACKAGE__"))         return -KEY___PACKAGE__;
4296             if (strEQ(d,"__DATA__"))            return KEY___DATA__;
4297             if (strEQ(d,"__END__"))             return KEY___END__;
4298         }
4299         break;
4300     case 'A':
4301         if (strEQ(d,"AUTOLOAD"))                return KEY_AUTOLOAD;
4302         break;
4303     case 'a':
4304         switch (len) {
4305         case 3:
4306             if (strEQ(d,"and"))                 return -KEY_and;
4307             if (strEQ(d,"abs"))                 return -KEY_abs;
4308             break;
4309         case 5:
4310             if (strEQ(d,"alarm"))               return -KEY_alarm;
4311             if (strEQ(d,"atan2"))               return -KEY_atan2;
4312             break;
4313         case 6:
4314             if (strEQ(d,"accept"))              return -KEY_accept;
4315             break;
4316         }
4317         break;
4318     case 'B':
4319         if (strEQ(d,"BEGIN"))                   return KEY_BEGIN;
4320         break;
4321     case 'b':
4322         if (strEQ(d,"bless"))                   return -KEY_bless;
4323         if (strEQ(d,"bind"))                    return -KEY_bind;
4324         if (strEQ(d,"binmode"))                 return -KEY_binmode;
4325         break;
4326     case 'C':
4327         if (strEQ(d,"CORE"))                    return -KEY_CORE;
4328         break;
4329     case 'c':
4330         switch (len) {
4331         case 3:
4332             if (strEQ(d,"cmp"))                 return -KEY_cmp;
4333             if (strEQ(d,"chr"))                 return -KEY_chr;
4334             if (strEQ(d,"cos"))                 return -KEY_cos;
4335             break;
4336         case 4:
4337             if (strEQ(d,"chop"))                return KEY_chop;
4338             break;
4339         case 5:
4340             if (strEQ(d,"close"))               return -KEY_close;
4341             if (strEQ(d,"chdir"))               return -KEY_chdir;
4342             if (strEQ(d,"chomp"))               return KEY_chomp;
4343             if (strEQ(d,"chmod"))               return -KEY_chmod;
4344             if (strEQ(d,"chown"))               return -KEY_chown;
4345             if (strEQ(d,"crypt"))               return -KEY_crypt;
4346             break;
4347         case 6:
4348             if (strEQ(d,"chroot"))              return -KEY_chroot;
4349             if (strEQ(d,"caller"))              return -KEY_caller;
4350             break;
4351         case 7:
4352             if (strEQ(d,"connect"))             return -KEY_connect;
4353             break;
4354         case 8:
4355             if (strEQ(d,"closedir"))            return -KEY_closedir;
4356             if (strEQ(d,"continue"))            return -KEY_continue;
4357             break;
4358         }
4359         break;
4360     case 'D':
4361         if (strEQ(d,"DESTROY"))                 return KEY_DESTROY;
4362         break;
4363     case 'd':
4364         switch (len) {
4365         case 2:
4366             if (strEQ(d,"do"))                  return KEY_do;
4367             break;
4368         case 3:
4369             if (strEQ(d,"die"))                 return -KEY_die;
4370             break;
4371         case 4:
4372             if (strEQ(d,"dump"))                return -KEY_dump;
4373             break;
4374         case 6:
4375             if (strEQ(d,"delete"))              return KEY_delete;
4376             break;
4377         case 7:
4378             if (strEQ(d,"defined"))             return KEY_defined;
4379             if (strEQ(d,"dbmopen"))             return -KEY_dbmopen;
4380             break;
4381         case 8:
4382             if (strEQ(d,"dbmclose"))            return -KEY_dbmclose;
4383             break;
4384         }
4385         break;
4386     case 'E':
4387         if (strEQ(d,"EQ")) { deprecate(d);      return -KEY_eq;}
4388         if (strEQ(d,"END"))                     return KEY_END;
4389         break;
4390     case 'e':
4391         switch (len) {
4392         case 2:
4393             if (strEQ(d,"eq"))                  return -KEY_eq;
4394             break;
4395         case 3:
4396             if (strEQ(d,"eof"))                 return -KEY_eof;
4397             if (strEQ(d,"exp"))                 return -KEY_exp;
4398             break;
4399         case 4:
4400             if (strEQ(d,"else"))                return KEY_else;
4401             if (strEQ(d,"exit"))                return -KEY_exit;
4402             if (strEQ(d,"eval"))                return KEY_eval;
4403             if (strEQ(d,"exec"))                return -KEY_exec;
4404             if (strEQ(d,"each"))                return KEY_each;
4405             break;
4406         case 5:
4407             if (strEQ(d,"elsif"))               return KEY_elsif;
4408             break;
4409         case 6:
4410             if (strEQ(d,"exists"))              return KEY_exists;
4411             if (strEQ(d,"elseif")) warn("elseif should be elsif");
4412             break;
4413         case 8:
4414             if (strEQ(d,"endgrent"))            return -KEY_endgrent;
4415             if (strEQ(d,"endpwent"))            return -KEY_endpwent;
4416             break;
4417         case 9:
4418             if (strEQ(d,"endnetent"))           return -KEY_endnetent;
4419             break;
4420         case 10:
4421             if (strEQ(d,"endhostent"))          return -KEY_endhostent;
4422             if (strEQ(d,"endservent"))          return -KEY_endservent;
4423             break;
4424         case 11:
4425             if (strEQ(d,"endprotoent"))         return -KEY_endprotoent;
4426             break;
4427         }
4428         break;
4429     case 'f':
4430         switch (len) {
4431         case 3:
4432             if (strEQ(d,"for"))                 return KEY_for;
4433             break;
4434         case 4:
4435             if (strEQ(d,"fork"))                return -KEY_fork;
4436             break;
4437         case 5:
4438             if (strEQ(d,"fcntl"))               return -KEY_fcntl;
4439             if (strEQ(d,"flock"))               return -KEY_flock;
4440             break;
4441         case 6:
4442             if (strEQ(d,"format"))              return KEY_format;
4443             if (strEQ(d,"fileno"))              return -KEY_fileno;
4444             break;
4445         case 7:
4446             if (strEQ(d,"foreach"))             return KEY_foreach;
4447             break;
4448         case 8:
4449             if (strEQ(d,"formline"))            return -KEY_formline;
4450             break;
4451         }
4452         break;
4453     case 'G':
4454         if (len == 2) {
4455             if (strEQ(d,"GT")) { deprecate(d);  return -KEY_gt;}
4456             if (strEQ(d,"GE")) { deprecate(d);  return -KEY_ge;}
4457         }
4458         break;
4459     case 'g':
4460         if (strnEQ(d,"get",3)) {
4461             d += 3;
4462             if (*d == 'p') {
4463                 switch (len) {
4464                 case 7:
4465                     if (strEQ(d,"ppid"))        return -KEY_getppid;
4466                     if (strEQ(d,"pgrp"))        return -KEY_getpgrp;
4467                     break;
4468                 case 8:
4469                     if (strEQ(d,"pwent"))       return -KEY_getpwent;
4470                     if (strEQ(d,"pwnam"))       return -KEY_getpwnam;
4471                     if (strEQ(d,"pwuid"))       return -KEY_getpwuid;
4472                     break;
4473                 case 11:
4474                     if (strEQ(d,"peername"))    return -KEY_getpeername;
4475                     if (strEQ(d,"protoent"))    return -KEY_getprotoent;
4476                     if (strEQ(d,"priority"))    return -KEY_getpriority;
4477                     break;
4478                 case 14:
4479                     if (strEQ(d,"protobyname")) return -KEY_getprotobyname;
4480                     break;
4481                 case 16:
4482                     if (strEQ(d,"protobynumber"))return -KEY_getprotobynumber;
4483                     break;
4484                 }
4485             }
4486             else if (*d == 'h') {
4487                 if (strEQ(d,"hostbyname"))      return -KEY_gethostbyname;
4488                 if (strEQ(d,"hostbyaddr"))      return -KEY_gethostbyaddr;
4489                 if (strEQ(d,"hostent"))         return -KEY_gethostent;
4490             }
4491             else if (*d == 'n') {
4492                 if (strEQ(d,"netbyname"))       return -KEY_getnetbyname;
4493                 if (strEQ(d,"netbyaddr"))       return -KEY_getnetbyaddr;
4494                 if (strEQ(d,"netent"))          return -KEY_getnetent;
4495             }
4496             else if (*d == 's') {
4497                 if (strEQ(d,"servbyname"))      return -KEY_getservbyname;
4498                 if (strEQ(d,"servbyport"))      return -KEY_getservbyport;
4499                 if (strEQ(d,"servent"))         return -KEY_getservent;
4500                 if (strEQ(d,"sockname"))        return -KEY_getsockname;
4501                 if (strEQ(d,"sockopt"))         return -KEY_getsockopt;
4502             }
4503             else if (*d == 'g') {
4504                 if (strEQ(d,"grent"))           return -KEY_getgrent;
4505                 if (strEQ(d,"grnam"))           return -KEY_getgrnam;
4506                 if (strEQ(d,"grgid"))           return -KEY_getgrgid;
4507             }
4508             else if (*d == 'l') {
4509                 if (strEQ(d,"login"))           return -KEY_getlogin;
4510             }
4511             else if (strEQ(d,"c"))              return -KEY_getc;
4512             break;
4513         }
4514         switch (len) {
4515         case 2:
4516             if (strEQ(d,"gt"))                  return -KEY_gt;
4517             if (strEQ(d,"ge"))                  return -KEY_ge;
4518             break;
4519         case 4:
4520             if (strEQ(d,"grep"))                return KEY_grep;
4521             if (strEQ(d,"goto"))                return KEY_goto;
4522             if (strEQ(d,"glob"))                return KEY_glob;
4523             break;
4524         case 6:
4525             if (strEQ(d,"gmtime"))              return -KEY_gmtime;
4526             break;
4527         }
4528         break;
4529     case 'h':
4530         if (strEQ(d,"hex"))                     return -KEY_hex;
4531         break;
4532     case 'I':
4533         if (strEQ(d,"INIT"))                    return KEY_INIT;
4534         break;
4535     case 'i':
4536         switch (len) {
4537         case 2:
4538             if (strEQ(d,"if"))                  return KEY_if;
4539             break;
4540         case 3:
4541             if (strEQ(d,"int"))                 return -KEY_int;
4542             break;
4543         case 5:
4544             if (strEQ(d,"index"))               return -KEY_index;
4545             if (strEQ(d,"ioctl"))               return -KEY_ioctl;
4546             break;
4547         }
4548         break;
4549     case 'j':
4550         if (strEQ(d,"join"))                    return -KEY_join;
4551         break;
4552     case 'k':
4553         if (len == 4) {
4554             if (strEQ(d,"keys"))                return KEY_keys;
4555             if (strEQ(d,"kill"))                return -KEY_kill;
4556         }
4557         break;
4558     case 'L':
4559         if (len == 2) {
4560             if (strEQ(d,"LT")) { deprecate(d);  return -KEY_lt;}
4561             if (strEQ(d,"LE")) { deprecate(d);  return -KEY_le;}
4562         }
4563         break;
4564     case 'l':
4565         switch (len) {
4566         case 2:
4567             if (strEQ(d,"lt"))                  return -KEY_lt;
4568             if (strEQ(d,"le"))                  return -KEY_le;
4569             if (strEQ(d,"lc"))                  return -KEY_lc;
4570             break;
4571         case 3:
4572             if (strEQ(d,"log"))                 return -KEY_log;
4573             break;
4574         case 4:
4575             if (strEQ(d,"last"))                return KEY_last;
4576             if (strEQ(d,"link"))                return -KEY_link;
4577             if (strEQ(d,"lock"))                return -KEY_lock;
4578             break;
4579         case 5:
4580             if (strEQ(d,"local"))               return KEY_local;
4581             if (strEQ(d,"lstat"))               return -KEY_lstat;
4582             break;
4583         case 6:
4584             if (strEQ(d,"length"))              return -KEY_length;
4585             if (strEQ(d,"listen"))              return -KEY_listen;
4586             break;
4587         case 7:
4588             if (strEQ(d,"lcfirst"))             return -KEY_lcfirst;
4589             break;
4590         case 9:
4591             if (strEQ(d,"localtime"))           return -KEY_localtime;
4592             break;
4593         }
4594         break;
4595     case 'm':
4596         switch (len) {
4597         case 1:                                 return KEY_m;
4598         case 2:
4599             if (strEQ(d,"my"))                  return KEY_my;
4600             break;
4601         case 3:
4602             if (strEQ(d,"map"))                 return KEY_map;
4603             break;
4604         case 5:
4605             if (strEQ(d,"mkdir"))               return -KEY_mkdir;
4606             break;
4607         case 6:
4608             if (strEQ(d,"msgctl"))              return -KEY_msgctl;
4609             if (strEQ(d,"msgget"))              return -KEY_msgget;
4610             if (strEQ(d,"msgrcv"))              return -KEY_msgrcv;
4611             if (strEQ(d,"msgsnd"))              return -KEY_msgsnd;
4612             break;
4613         }
4614         break;
4615     case 'N':
4616         if (strEQ(d,"NE")) { deprecate(d);      return -KEY_ne;}
4617         break;
4618     case 'n':
4619         if (strEQ(d,"next"))                    return KEY_next;
4620         if (strEQ(d,"ne"))                      return -KEY_ne;
4621         if (strEQ(d,"not"))                     return -KEY_not;
4622         if (strEQ(d,"no"))                      return KEY_no;
4623         break;
4624     case 'o':
4625         switch (len) {
4626         case 2:
4627             if (strEQ(d,"or"))                  return -KEY_or;
4628             break;
4629         case 3:
4630             if (strEQ(d,"ord"))                 return -KEY_ord;
4631             if (strEQ(d,"oct"))                 return -KEY_oct;
4632             if (strEQ(d,"our")) { deprecate("reserved word \"our\"");
4633                                                 return 0;}
4634             break;
4635         case 4:
4636             if (strEQ(d,"open"))                return -KEY_open;
4637             break;
4638         case 7:
4639             if (strEQ(d,"opendir"))             return -KEY_opendir;
4640             break;
4641         }
4642         break;
4643     case 'p':
4644         switch (len) {
4645         case 3:
4646             if (strEQ(d,"pop"))                 return KEY_pop;
4647             if (strEQ(d,"pos"))                 return KEY_pos;
4648             break;
4649         case 4:
4650             if (strEQ(d,"push"))                return KEY_push;
4651             if (strEQ(d,"pack"))                return -KEY_pack;
4652             if (strEQ(d,"pipe"))                return -KEY_pipe;
4653             break;
4654         case 5:
4655             if (strEQ(d,"print"))               return KEY_print;
4656             break;
4657         case 6:
4658             if (strEQ(d,"printf"))              return KEY_printf;
4659             break;
4660         case 7:
4661             if (strEQ(d,"package"))             return KEY_package;
4662             break;
4663         case 9:
4664             if (strEQ(d,"prototype"))           return KEY_prototype;
4665         }
4666         break;
4667     case 'q':
4668         if (len <= 2) {
4669             if (strEQ(d,"q"))                   return KEY_q;
4670             if (strEQ(d,"qr"))                  return KEY_qr;
4671             if (strEQ(d,"qq"))                  return KEY_qq;
4672             if (strEQ(d,"qw"))                  return KEY_qw;
4673             if (strEQ(d,"qx"))                  return KEY_qx;
4674         }
4675         else if (strEQ(d,"quotemeta"))          return -KEY_quotemeta;
4676         break;
4677     case 'r':
4678         switch (len) {
4679         case 3:
4680             if (strEQ(d,"ref"))                 return -KEY_ref;
4681             break;
4682         case 4:
4683             if (strEQ(d,"read"))                return -KEY_read;
4684             if (strEQ(d,"rand"))                return -KEY_rand;
4685             if (strEQ(d,"recv"))                return -KEY_recv;
4686             if (strEQ(d,"redo"))                return KEY_redo;
4687             break;
4688         case 5:
4689             if (strEQ(d,"rmdir"))               return -KEY_rmdir;
4690             if (strEQ(d,"reset"))               return -KEY_reset;
4691             break;
4692         case 6:
4693             if (strEQ(d,"return"))              return KEY_return;
4694             if (strEQ(d,"rename"))              return -KEY_rename;
4695             if (strEQ(d,"rindex"))              return -KEY_rindex;
4696             break;
4697         case 7:
4698             if (strEQ(d,"require"))             return -KEY_require;
4699             if (strEQ(d,"reverse"))             return -KEY_reverse;
4700             if (strEQ(d,"readdir"))             return -KEY_readdir;
4701             break;
4702         case 8:
4703             if (strEQ(d,"readlink"))            return -KEY_readlink;
4704             if (strEQ(d,"readline"))            return -KEY_readline;
4705             if (strEQ(d,"readpipe"))            return -KEY_readpipe;
4706             break;
4707         case 9:
4708             if (strEQ(d,"rewinddir"))           return -KEY_rewinddir;
4709             break;
4710         }
4711         break;
4712     case 's':
4713         switch (d[1]) {
4714         case 0:                                 return KEY_s;
4715         case 'c':
4716             if (strEQ(d,"scalar"))              return KEY_scalar;
4717             break;
4718         case 'e':
4719             switch (len) {
4720             case 4:
4721                 if (strEQ(d,"seek"))            return -KEY_seek;
4722                 if (strEQ(d,"send"))            return -KEY_send;
4723                 break;
4724             case 5:
4725                 if (strEQ(d,"semop"))           return -KEY_semop;
4726                 break;
4727             case 6:
4728                 if (strEQ(d,"select"))          return -KEY_select;
4729                 if (strEQ(d,"semctl"))          return -KEY_semctl;
4730                 if (strEQ(d,"semget"))          return -KEY_semget;
4731                 break;
4732             case 7:
4733                 if (strEQ(d,"setpgrp"))         return -KEY_setpgrp;
4734                 if (strEQ(d,"seekdir"))         return -KEY_seekdir;
4735                 break;
4736             case 8:
4737                 if (strEQ(d,"setpwent"))        return -KEY_setpwent;
4738                 if (strEQ(d,"setgrent"))        return -KEY_setgrent;
4739                 break;
4740             case 9:
4741                 if (strEQ(d,"setnetent"))       return -KEY_setnetent;
4742                 break;
4743             case 10:
4744                 if (strEQ(d,"setsockopt"))      return -KEY_setsockopt;
4745                 if (strEQ(d,"sethostent"))      return -KEY_sethostent;
4746                 if (strEQ(d,"setservent"))      return -KEY_setservent;
4747                 break;
4748             case 11:
4749                 if (strEQ(d,"setpriority"))     return -KEY_setpriority;
4750                 if (strEQ(d,"setprotoent"))     return -KEY_setprotoent;
4751                 break;
4752             }
4753             break;
4754         case 'h':
4755             switch (len) {
4756             case 5:
4757                 if (strEQ(d,"shift"))           return KEY_shift;
4758                 break;
4759             case 6:
4760                 if (strEQ(d,"shmctl"))          return -KEY_shmctl;
4761                 if (strEQ(d,"shmget"))          return -KEY_shmget;
4762                 break;
4763             case 7:
4764                 if (strEQ(d,"shmread"))         return -KEY_shmread;
4765                 break;
4766             case 8:
4767                 if (strEQ(d,"shmwrite"))        return -KEY_shmwrite;
4768                 if (strEQ(d,"shutdown"))        return -KEY_shutdown;
4769                 break;
4770             }
4771             break;
4772         case 'i':
4773             if (strEQ(d,"sin"))                 return -KEY_sin;
4774             break;
4775         case 'l':
4776             if (strEQ(d,"sleep"))               return -KEY_sleep;
4777             break;
4778         case 'o':
4779             if (strEQ(d,"sort"))                return KEY_sort;
4780             if (strEQ(d,"socket"))              return -KEY_socket;
4781             if (strEQ(d,"socketpair"))          return -KEY_socketpair;
4782             break;
4783         case 'p':
4784             if (strEQ(d,"split"))               return KEY_split;
4785             if (strEQ(d,"sprintf"))             return -KEY_sprintf;
4786             if (strEQ(d,"splice"))              return KEY_splice;
4787             break;
4788         case 'q':
4789             if (strEQ(d,"sqrt"))                return -KEY_sqrt;
4790             break;
4791         case 'r':
4792             if (strEQ(d,"srand"))               return -KEY_srand;
4793             break;
4794         case 't':
4795             if (strEQ(d,"stat"))                return -KEY_stat;
4796             if (strEQ(d,"study"))               return KEY_study;
4797             break;
4798         case 'u':
4799             if (strEQ(d,"substr"))              return -KEY_substr;
4800             if (strEQ(d,"sub"))                 return KEY_sub;
4801             break;
4802         case 'y':
4803             switch (len) {
4804             case 6:
4805                 if (strEQ(d,"system"))          return -KEY_system;
4806                 break;
4807             case 7:
4808                 if (strEQ(d,"symlink"))         return -KEY_symlink;
4809                 if (strEQ(d,"syscall"))         return -KEY_syscall;
4810                 if (strEQ(d,"sysopen"))         return -KEY_sysopen;
4811                 if (strEQ(d,"sysread"))         return -KEY_sysread;
4812                 if (strEQ(d,"sysseek"))         return -KEY_sysseek;
4813                 break;
4814             case 8:
4815                 if (strEQ(d,"syswrite"))        return -KEY_syswrite;
4816                 break;
4817             }
4818             break;
4819         }
4820         break;
4821     case 't':
4822         switch (len) {
4823         case 2:
4824             if (strEQ(d,"tr"))                  return KEY_tr;
4825             break;
4826         case 3:
4827             if (strEQ(d,"tie"))                 return KEY_tie;
4828             break;
4829         case 4:
4830             if (strEQ(d,"tell"))                return -KEY_tell;
4831             if (strEQ(d,"tied"))                return KEY_tied;
4832             if (strEQ(d,"time"))                return -KEY_time;
4833             break;
4834         case 5:
4835             if (strEQ(d,"times"))               return -KEY_times;
4836             break;
4837         case 7:
4838             if (strEQ(d,"telldir"))             return -KEY_telldir;
4839             break;
4840         case 8:
4841             if (strEQ(d,"truncate"))            return -KEY_truncate;
4842             break;
4843         }
4844         break;
4845     case 'u':
4846         switch (len) {
4847         case 2:
4848             if (strEQ(d,"uc"))                  return -KEY_uc;
4849             break;
4850         case 3:
4851             if (strEQ(d,"use"))                 return KEY_use;
4852             break;
4853         case 5:
4854             if (strEQ(d,"undef"))               return KEY_undef;
4855             if (strEQ(d,"until"))               return KEY_until;
4856             if (strEQ(d,"untie"))               return KEY_untie;
4857             if (strEQ(d,"utime"))               return -KEY_utime;
4858             if (strEQ(d,"umask"))               return -KEY_umask;
4859             break;
4860         case 6:
4861             if (strEQ(d,"unless"))              return KEY_unless;
4862             if (strEQ(d,"unpack"))              return -KEY_unpack;
4863             if (strEQ(d,"unlink"))              return -KEY_unlink;
4864             break;
4865         case 7:
4866             if (strEQ(d,"unshift"))             return KEY_unshift;
4867             if (strEQ(d,"ucfirst"))             return -KEY_ucfirst;
4868             break;
4869         }
4870         break;
4871     case 'v':
4872         if (strEQ(d,"values"))                  return -KEY_values;
4873         if (strEQ(d,"vec"))                     return -KEY_vec;
4874         break;
4875     case 'w':
4876         switch (len) {
4877         case 4:
4878             if (strEQ(d,"warn"))                return -KEY_warn;
4879             if (strEQ(d,"wait"))                return -KEY_wait;
4880             break;
4881         case 5:
4882             if (strEQ(d,"while"))               return KEY_while;
4883             if (strEQ(d,"write"))               return -KEY_write;
4884             break;
4885         case 7:
4886             if (strEQ(d,"waitpid"))             return -KEY_waitpid;
4887             break;
4888         case 9:
4889             if (strEQ(d,"wantarray"))           return -KEY_wantarray;
4890             break;
4891         }
4892         break;
4893     case 'x':
4894         if (len == 1)                           return -KEY_x;
4895         if (strEQ(d,"xor"))                     return -KEY_xor;
4896         break;
4897     case 'y':
4898         if (len == 1)                           return KEY_y;
4899         break;
4900     case 'z':
4901         break;
4902     }
4903     return 0;
4904 }
4905
4906 STATIC void
4907 checkcomma(register char *s, char *name, char *what)
4908 {
4909     char *w;
4910
4911     if (*s == ' ' && s[1] == '(') {     /* XXX gotta be a better way */
4912         dTHR;                           /* only for ckWARN */
4913         if (ckWARN(WARN_SYNTAX)) {
4914             int level = 1;
4915             for (w = s+2; *w && level; w++) {
4916                 if (*w == '(')
4917                     ++level;
4918                 else if (*w == ')')
4919                     --level;
4920             }
4921             if (*w)
4922                 for (; *w && isSPACE(*w); w++) ;
4923             if (!*w || !strchr(";|})]oaiuw!=", *w))     /* an advisory hack only... */
4924                 warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
4925         }
4926     }
4927     while (s < PL_bufend && isSPACE(*s))
4928         s++;
4929     if (*s == '(')
4930         s++;
4931     while (s < PL_bufend && isSPACE(*s))
4932         s++;
4933     if (isIDFIRST_lazy(s)) {
4934         w = s++;
4935         while (isALNUM_lazy(s))
4936             s++;
4937         while (s < PL_bufend && isSPACE(*s))
4938             s++;
4939         if (*s == ',') {
4940             int kw;
4941             *s = '\0';
4942             kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0;
4943             *s = ',';
4944             if (kw)
4945                 return;
4946             croak("No comma allowed after %s", what);
4947         }
4948     }
4949 }
4950
4951 STATIC SV *
4952 new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
4953 {
4954     dSP;
4955     HV *table = GvHV(PL_hintgv);                 /* ^H */
4956     BINOP myop;
4957     SV *res;
4958     bool oldcatch = CATCH_GET;
4959     SV **cvp;
4960     SV *cv, *typesv;
4961     char buf[128];
4962
4963     if (!table) {
4964         yyerror("%^H is not defined");
4965         return sv;
4966     }
4967     cvp = hv_fetch(table, key, strlen(key), FALSE);
4968     if (!cvp || !SvOK(*cvp)) {
4969         sprintf(buf,"$^H{%s} is not defined", key);
4970         yyerror(buf);
4971         return sv;
4972     }
4973     sv_2mortal(sv);                     /* Parent created it permanently */
4974     cv = *cvp;
4975     if (!pv)
4976         pv = sv_2mortal(newSVpv(s, len));
4977     if (type)
4978         typesv = sv_2mortal(newSVpv(type, 0));
4979     else
4980         typesv = &PL_sv_undef;
4981     CATCH_SET(TRUE);
4982     Zero(&myop, 1, BINOP);
4983     myop.op_last = (OP *) &myop;
4984     myop.op_next = Nullop;
4985     myop.op_flags = OPf_WANT_SCALAR | OPf_STACKED;
4986
4987     PUSHSTACKi(PERLSI_OVERLOAD);
4988     ENTER;
4989     SAVEOP();
4990     PL_op = (OP *) &myop;
4991     if (PERLDB_SUB && PL_curstash != PL_debstash)
4992         PL_op->op_private |= OPpENTERSUB_DB;
4993     PUTBACK;
4994     pp_pushmark(ARGS);
4995
4996     EXTEND(sp, 4);
4997     PUSHs(pv);
4998     PUSHs(sv);
4999     PUSHs(typesv);
5000     PUSHs(cv);
5001     PUTBACK;
5002
5003     if (PL_op = pp_entersub(ARGS))
5004       CALLRUNOPS();
5005     LEAVE;
5006     SPAGAIN;
5007
5008     res = POPs;
5009     PUTBACK;
5010     CATCH_SET(oldcatch);
5011     POPSTACK;
5012
5013     if (!SvOK(res)) {
5014         sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
5015         yyerror(buf);
5016     }
5017     return SvREFCNT_inc(res);
5018 }
5019
5020 STATIC char *
5021 scan_word(register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp)
5022 {
5023     register char *d = dest;
5024     register char *e = d + destlen - 3;  /* two-character token, ending NUL */
5025     for (;;) {
5026         if (d >= e)
5027             croak(ident_too_long);
5028         if (isALNUM(*s))        /* UTF handled below */
5029             *d++ = *s++;
5030         else if (*s == '\'' && allow_package && isIDFIRST_lazy(s+1)) {
5031             *d++ = ':';
5032             *d++ = ':';
5033             s++;
5034         }
5035         else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') {
5036             *d++ = *s++;
5037             *d++ = *s++;
5038         }
5039         else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5040             char *t = s + UTF8SKIP(s);
5041             while (*t & 0x80 && is_utf8_mark((U8*)t))
5042                 t += UTF8SKIP(t);
5043             if (d + (t - s) > e)
5044                 croak(ident_too_long);
5045             Copy(s, d, t - s, char);
5046             d += t - s;
5047             s = t;
5048         }
5049         else {
5050             *d = '\0';
5051             *slp = d - dest;
5052             return s;
5053         }
5054     }
5055 }
5056
5057 STATIC char *
5058 scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I32 ck_uni)
5059 {
5060     register char *d;
5061     register char *e;
5062     char *bracket = 0;
5063     char funny = *s++;
5064
5065     if (PL_lex_brackets == 0)
5066         PL_lex_fakebrack = 0;
5067     if (isSPACE(*s))
5068         s = skipspace(s);
5069     d = dest;
5070     e = d + destlen - 3;        /* two-character token, ending NUL */
5071     if (isDIGIT(*s)) {
5072         while (isDIGIT(*s)) {
5073             if (d >= e)
5074                 croak(ident_too_long);
5075             *d++ = *s++;
5076         }
5077     }
5078     else {
5079         for (;;) {
5080             if (d >= e)
5081                 croak(ident_too_long);
5082             if (isALNUM(*s))    /* UTF handled below */
5083                 *d++ = *s++;
5084             else if (*s == '\'' && isIDFIRST_lazy(s+1)) {
5085                 *d++ = ':';
5086                 *d++ = ':';
5087                 s++;
5088             }
5089             else if (*s == ':' && s[1] == ':') {
5090                 *d++ = *s++;
5091                 *d++ = *s++;
5092             }
5093             else if (UTF && *(U8*)s >= 0xc0 && isALNUM_utf8((U8*)s)) {
5094                 char *t = s + UTF8SKIP(s);
5095                 while (*t & 0x80 && is_utf8_mark((U8*)t))
5096                     t += UTF8SKIP(t);
5097                 if (d + (t - s) > e)
5098                     croak(ident_too_long);
5099                 Copy(s, d, t - s, char);
5100                 d += t - s;
5101                 s = t;
5102             }
5103             else
5104                 break;
5105         }
5106     }
5107     *d = '\0';
5108     d = dest;
5109     if (*d) {
5110         if (PL_lex_state != LEX_NORMAL)
5111             PL_lex_state = LEX_INTERPENDMAYBE;
5112         return s;
5113     }
5114     if (*s == '$' && s[1] &&
5115         (isALNUM_lazy(s+1) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) )
5116     {
5117         return s;
5118     }
5119     if (*s == '{') {
5120         bracket = s;
5121         s++;
5122     }
5123     else if (ck_uni)
5124         check_uni();
5125     if (s < send)
5126         *d = *s++;
5127     d[1] = '\0';
5128     if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) {
5129         *d = toCTRL(*s);
5130         s++;
5131     }
5132     if (bracket) {
5133         if (isSPACE(s[-1])) {
5134             while (s < send) {
5135                 char ch = *s++;
5136                 if (ch != ' ' && ch != '\t') {
5137                     *d = ch;
5138                     break;
5139                 }
5140             }
5141         }
5142         if (isIDFIRST_lazy(d)) {
5143             d++;
5144             if (UTF) {
5145                 e = s;
5146                 while (e < send && isALNUM_lazy(e) || *e == ':') {
5147                     e += UTF8SKIP(e);
5148                     while (e < send && *e & 0x80 && is_utf8_mark((U8*)e))
5149                         e += UTF8SKIP(e);
5150                 }
5151                 Copy(s, d, e - s, char);
5152                 d += e - s;
5153                 s = e;
5154             }
5155             else {
5156                 while (isALNUM(*s) || *s == ':')
5157                     *d++ = *s++;
5158             }
5159             *d = '\0';
5160             while (s < send && (*s == ' ' || *s == '\t')) s++;
5161             if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
5162                 dTHR;                   /* only for ckWARN */
5163                 if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
5164                     char *brack = *s == '[' ? "[...]" : "{...}";
5165                     warner(WARN_AMBIGUOUS,
5166                         "Ambiguous use of %c{%s%s} resolved to %c%s%s",
5167                         funny, dest, brack, funny, dest, brack);
5168                 }
5169                 PL_lex_fakebrack = PL_lex_brackets+1;
5170                 bracket++;
5171                 PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR;
5172                 return s;
5173             }
5174         }
5175         if (*s == '}') {
5176             s++;
5177             if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets)
5178                 PL_lex_state = LEX_INTERPEND;
5179             if (funny == '#')
5180                 funny = '@';
5181             if (PL_lex_state == LEX_NORMAL) {
5182                 dTHR;                   /* only for ckWARN */
5183                 if (ckWARN(WARN_AMBIGUOUS) &&
5184                     (keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
5185                 {
5186                     warner(WARN_AMBIGUOUS,
5187                         "Ambiguous use of %c{%s} resolved to %c%s",
5188                         funny, dest, funny, dest);
5189                 }
5190             }
5191         }
5192         else {
5193             s = bracket;                /* let the parser handle it */
5194             *dest = '\0';
5195         }
5196     }
5197     else if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets && !intuit_more(s))
5198         PL_lex_state = LEX_INTERPEND;
5199     return s;
5200 }
5201
5202 void pmflag(U16 *pmfl, int ch)
5203 {
5204     if (ch == 'i')
5205         *pmfl |= PMf_FOLD;
5206     else if (ch == 'g')
5207         *pmfl |= PMf_GLOBAL;
5208     else if (ch == 'c')
5209         *pmfl |= PMf_CONTINUE;
5210     else if (ch == 'o')
5211         *pmfl |= PMf_KEEP;
5212     else if (ch == 'm')
5213         *pmfl |= PMf_MULTILINE;
5214     else if (ch == 's')
5215         *pmfl |= PMf_SINGLELINE;
5216     else if (ch == 'x')
5217         *pmfl |= PMf_EXTENDED;
5218 }
5219
5220 STATIC char *
5221 scan_pat(char *start, I32 type)
5222 {
5223     PMOP *pm;
5224     char *s;
5225
5226     s = scan_str(start);
5227     if (!s) {
5228         if (PL_lex_stuff)
5229             SvREFCNT_dec(PL_lex_stuff);
5230         PL_lex_stuff = Nullsv;
5231         croak("Search pattern not terminated");
5232     }
5233
5234     pm = (PMOP*)newPMOP(type, 0);
5235     if (PL_multi_open == '?')
5236         pm->op_pmflags |= PMf_ONCE;
5237     if(type == OP_QR) {
5238         while (*s && strchr("iomsx", *s))
5239             pmflag(&pm->op_pmflags,*s++);
5240     }
5241     else {
5242         while (*s && strchr("iogcmsx", *s))
5243             pmflag(&pm->op_pmflags,*s++);
5244     }
5245     pm->op_pmpermflags = pm->op_pmflags;
5246
5247     PL_lex_op = (OP*)pm;
5248     yylval.ival = OP_MATCH;
5249     return s;
5250 }
5251
5252 STATIC char *
5253 scan_subst(char *start)
5254 {
5255     register char *s;
5256     register PMOP *pm;
5257     I32 first_start;
5258     I32 es = 0;
5259
5260     yylval.ival = OP_NULL;
5261
5262     s = scan_str(start);
5263
5264     if (!s) {
5265         if (PL_lex_stuff)
5266             SvREFCNT_dec(PL_lex_stuff);
5267         PL_lex_stuff = Nullsv;
5268         croak("Substitution pattern not terminated");
5269     }
5270
5271     if (s[-1] == PL_multi_open)
5272         s--;
5273
5274     first_start = PL_multi_start;
5275     s = scan_str(s);
5276     if (!s) {
5277         if (PL_lex_stuff)
5278             SvREFCNT_dec(PL_lex_stuff);
5279         PL_lex_stuff = Nullsv;
5280         if (PL_lex_repl)
5281             SvREFCNT_dec(PL_lex_repl);
5282         PL_lex_repl = Nullsv;
5283         croak("Substitution replacement not terminated");
5284     }
5285     PL_multi_start = first_start;       /* so whole substitution is taken together */
5286
5287     pm = (PMOP*)newPMOP(OP_SUBST, 0);
5288     while (*s) {
5289         if (*s == 'e') {
5290             s++;
5291             es++;
5292         }
5293         else if (strchr("iogcmsx", *s))
5294             pmflag(&pm->op_pmflags,*s++);
5295         else
5296             break;
5297     }
5298
5299     if (es) {
5300         SV *repl;
5301         pm->op_pmflags |= PMf_EVAL;
5302         repl = newSVpv("",0);
5303         while (es-- > 0)
5304             sv_catpv(repl, es ? "eval " : "do ");
5305         sv_catpvn(repl, "{ ", 2);
5306         sv_catsv(repl, PL_lex_repl);
5307         sv_catpvn(repl, " };", 2);
5308         SvCOMPILED_on(repl);
5309         SvREFCNT_dec(PL_lex_repl);
5310         PL_lex_repl = repl;
5311     }
5312
5313     pm->op_pmpermflags = pm->op_pmflags;
5314     PL_lex_op = (OP*)pm;
5315     yylval.ival = OP_SUBST;
5316     return s;
5317 }
5318
5319 STATIC char *
5320 scan_trans(char *start)
5321 {
5322     register char* s;
5323     OP *o;
5324     short *tbl;
5325     I32 squash;
5326     I32 del;
5327     I32 complement;
5328     I32 utf8;
5329     I32 count = 0;
5330
5331     yylval.ival = OP_NULL;
5332
5333     s = scan_str(start);
5334     if (!s) {
5335         if (PL_lex_stuff)
5336             SvREFCNT_dec(PL_lex_stuff);
5337         PL_lex_stuff = Nullsv;
5338         croak("Transliteration pattern not terminated");
5339     }
5340     if (s[-1] == PL_multi_open)
5341         s--;
5342
5343     s = scan_str(s);
5344     if (!s) {
5345         if (PL_lex_stuff)
5346             SvREFCNT_dec(PL_lex_stuff);
5347         PL_lex_stuff = Nullsv;
5348         if (PL_lex_repl)
5349             SvREFCNT_dec(PL_lex_repl);
5350         PL_lex_repl = Nullsv;
5351         croak("Transliteration replacement not terminated");
5352     }
5353
5354     if (UTF) {
5355         o = newSVOP(OP_TRANS, 0, 0);
5356         utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
5357     }
5358     else {
5359         New(803,tbl,256,short);
5360         o = newPVOP(OP_TRANS, 0, (char*)tbl);
5361         utf8 = 0;
5362     }
5363
5364     complement = del = squash = 0;
5365     while (strchr("cdsCU", *s)) {
5366         if (*s == 'c')
5367             complement = OPpTRANS_COMPLEMENT;
5368         else if (*s == 'd')
5369             del = OPpTRANS_DELETE;
5370         else if (*s == 's')
5371             squash = OPpTRANS_SQUASH;
5372         else {
5373             switch (count++) {
5374             case 0:
5375                 if (*s == 'C')
5376                     utf8 &= ~OPpTRANS_FROM_UTF;
5377                 else
5378                     utf8 |= OPpTRANS_FROM_UTF;
5379                 break;
5380             case 1:
5381                 if (*s == 'C')
5382                     utf8 &= ~OPpTRANS_TO_UTF;
5383                 else
5384                     utf8 |= OPpTRANS_TO_UTF;
5385                 break;
5386             default:
5387                 croak("Too many /C and /U options");
5388             }
5389         }
5390         s++;
5391     }
5392     o->op_private = del|squash|complement|utf8;
5393
5394     PL_lex_op = o;
5395     yylval.ival = OP_TRANS;
5396     return s;
5397 }
5398
5399 STATIC char *
5400 scan_heredoc(register char *s)
5401 {
5402     dTHR;
5403     SV *herewas;
5404     I32 op_type = OP_SCALAR;
5405     I32 len;
5406     SV *tmpstr;
5407     char term;
5408     register char *d;
5409     register char *e;
5410     char *peek;
5411     int outer = (PL_rsfp && !(PL_lex_inwhat == OP_SCALAR));
5412
5413     s += 2;
5414     d = PL_tokenbuf;
5415     e = PL_tokenbuf + sizeof PL_tokenbuf - 1;
5416     if (!outer)
5417         *d++ = '\n';
5418     for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ;
5419     if (*peek && strchr("`'\"",*peek)) {
5420         s = peek;
5421         term = *s++;
5422         s = delimcpy(d, e, s, PL_bufend, term, &len);
5423         d += len;
5424         if (s < PL_bufend)
5425             s++;
5426     }
5427     else {
5428         if (*s == '\\')
5429             s++, term = '\'';
5430         else
5431             term = '"';
5432         if (!isALNUM_lazy(s))
5433             deprecate("bare << to mean <<\"\"");
5434         for (; isALNUM_lazy(s); s++) {
5435             if (d < e)
5436                 *d++ = *s;
5437         }
5438     }
5439     if (d >= PL_tokenbuf + sizeof PL_tokenbuf - 1)
5440         croak("Delimiter for here document is too long");
5441     *d++ = '\n';
5442     *d = '\0';
5443     len = d - PL_tokenbuf;
5444 #ifndef PERL_STRICT_CR
5445     d = strchr(s, '\r');
5446     if (d) {
5447         char *olds = s;
5448         s = d;
5449         while (s < PL_bufend) {
5450             if (*s == '\r') {
5451                 *d++ = '\n';
5452                 if (*++s == '\n')
5453                     s++;
5454             }
5455             else if (*s == '\n' && s[1] == '\r') {      /* \015\013 on a mac? */
5456                 *d++ = *s++;
5457                 s++;
5458             }
5459             else
5460                 *d++ = *s++;
5461         }
5462         *d = '\0';
5463         PL_bufend = d;
5464         SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5465         s = olds;
5466     }
5467 #endif
5468     d = "\n";
5469     if (outer || !(d=ninstr(s,PL_bufend,d,d+1)))
5470         herewas = newSVpv(s,PL_bufend-s);
5471     else
5472         s--, herewas = newSVpv(s,d-s);
5473     s += SvCUR(herewas);
5474
5475     tmpstr = NEWSV(87,79);
5476     sv_upgrade(tmpstr, SVt_PVIV);
5477     if (term == '\'') {
5478         op_type = OP_CONST;
5479         SvIVX(tmpstr) = -1;
5480     }
5481     else if (term == '`') {
5482         op_type = OP_BACKTICK;
5483         SvIVX(tmpstr) = '\\';
5484     }
5485
5486     CLINE;
5487     PL_multi_start = PL_curcop->cop_line;
5488     PL_multi_open = PL_multi_close = '<';
5489     term = *PL_tokenbuf;
5490     if (!outer) {
5491         d = s;
5492         while (s < PL_bufend &&
5493           (*s != term || memNE(s,PL_tokenbuf,len)) ) {
5494             if (*s++ == '\n')
5495                 PL_curcop->cop_line++;
5496         }
5497         if (s >= PL_bufend) {
5498             PL_curcop->cop_line = PL_multi_start;
5499             missingterm(PL_tokenbuf);
5500         }
5501         sv_setpvn(tmpstr,d+1,s-d);
5502         s += len - 1;
5503         PL_curcop->cop_line++;  /* the preceding stmt passes a newline */
5504
5505         sv_catpvn(herewas,s,PL_bufend-s);
5506         sv_setsv(PL_linestr,herewas);
5507         PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart = SvPVX(PL_linestr);
5508         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5509     }
5510     else
5511         sv_setpvn(tmpstr,"",0);   /* avoid "uninitialized" warning */
5512     while (s >= PL_bufend) {    /* multiple line string? */
5513         if (!outer ||
5514          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5515             PL_curcop->cop_line = PL_multi_start;
5516             missingterm(PL_tokenbuf);
5517         }
5518         PL_curcop->cop_line++;
5519         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5520 #ifndef PERL_STRICT_CR
5521         if (PL_bufend - PL_linestart >= 2) {
5522             if ((PL_bufend[-2] == '\r' && PL_bufend[-1] == '\n') ||
5523                 (PL_bufend[-2] == '\n' && PL_bufend[-1] == '\r'))
5524             {
5525                 PL_bufend[-2] = '\n';
5526                 PL_bufend--;
5527                 SvCUR_set(PL_linestr, PL_bufend - SvPVX(PL_linestr));
5528             }
5529             else if (PL_bufend[-1] == '\r')
5530                 PL_bufend[-1] = '\n';
5531         }
5532         else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r')
5533             PL_bufend[-1] = '\n';
5534 #endif
5535         if (PERLDB_LINE && PL_curstash != PL_debstash) {
5536             SV *sv = NEWSV(88,0);
5537
5538             sv_upgrade(sv, SVt_PVMG);
5539             sv_setsv(sv,PL_linestr);
5540             av_store(GvAV(PL_curcop->cop_filegv),
5541               (I32)PL_curcop->cop_line,sv);
5542         }
5543         if (*s == term && memEQ(s,PL_tokenbuf,len)) {
5544             s = PL_bufend - 1;
5545             *s = ' ';
5546             sv_catsv(PL_linestr,herewas);
5547             PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5548         }
5549         else {
5550             s = PL_bufend;
5551             sv_catsv(tmpstr,PL_linestr);
5552         }
5553     }
5554     PL_multi_end = PL_curcop->cop_line;
5555     s++;
5556     if (SvCUR(tmpstr) + 5 < SvLEN(tmpstr)) {
5557         SvLEN_set(tmpstr, SvCUR(tmpstr) + 1);
5558         Renew(SvPVX(tmpstr), SvLEN(tmpstr), char);
5559     }
5560     SvREFCNT_dec(herewas);
5561     PL_lex_stuff = tmpstr;
5562     yylval.ival = op_type;
5563     return s;
5564 }
5565
5566 /* scan_inputsymbol
5567    takes: current position in input buffer
5568    returns: new position in input buffer
5569    side-effects: yylval and lex_op are set.
5570
5571    This code handles:
5572
5573    <>           read from ARGV
5574    <FH>         read from filehandle
5575    <pkg::FH>    read from package qualified filehandle
5576    <pkg'FH>     read from package qualified filehandle
5577    <$fh>        read from filehandle in $fh
5578    <*.h>        filename glob
5579
5580 */
5581
5582 STATIC char *
5583 scan_inputsymbol(char *start)
5584 {
5585     register char *s = start;           /* current position in buffer */
5586     register char *d;
5587     register char *e;
5588     I32 len;
5589
5590     d = PL_tokenbuf;                    /* start of temp holding space */
5591     e = PL_tokenbuf + sizeof PL_tokenbuf;       /* end of temp holding space */
5592     s = delimcpy(d, e, s + 1, PL_bufend, '>', &len);    /* extract until > */
5593
5594     /* die if we didn't have space for the contents of the <>,
5595        or if it didn't end
5596     */
5597
5598     if (len >= sizeof PL_tokenbuf)
5599         croak("Excessively long <> operator");
5600     if (s >= PL_bufend)
5601         croak("Unterminated <> operator");
5602
5603     s++;
5604
5605     /* check for <$fh>
5606        Remember, only scalar variables are interpreted as filehandles by
5607        this code.  Anything more complex (e.g., <$fh{$num}>) will be
5608        treated as a glob() call.
5609        This code makes use of the fact that except for the $ at the front,
5610        a scalar variable and a filehandle look the same.
5611     */
5612     if (*d == '$' && d[1]) d++;
5613
5614     /* allow <Pkg'VALUE> or <Pkg::VALUE> */
5615     while (*d && (isALNUM_lazy(d) || *d == '\'' || *d == ':'))
5616         d++;
5617
5618     /* If we've tried to read what we allow filehandles to look like, and
5619        there's still text left, then it must be a glob() and not a getline.
5620        Use scan_str to pull out the stuff between the <> and treat it
5621        as nothing more than a string.
5622     */
5623
5624     if (d - PL_tokenbuf != len) {
5625         yylval.ival = OP_GLOB;
5626         set_csh();
5627         s = scan_str(start);
5628         if (!s)
5629            croak("Glob not terminated");
5630         return s;
5631     }
5632     else {
5633         /* we're in a filehandle read situation */
5634         d = PL_tokenbuf;
5635
5636         /* turn <> into <ARGV> */
5637         if (!len)
5638             (void)strcpy(d,"ARGV");
5639
5640         /* if <$fh>, create the ops to turn the variable into a
5641            filehandle
5642         */
5643         if (*d == '$') {
5644             I32 tmp;
5645
5646             /* try to find it in the pad for this block, otherwise find
5647                add symbol table ops
5648             */
5649             if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
5650                 OP *o = newOP(OP_PADSV, 0);
5651                 o->op_targ = tmp;
5652                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
5653             }
5654             else {
5655                 GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
5656                 PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
5657                                         newUNOP(OP_RV2GV, 0,
5658                                             newUNOP(OP_RV2SV, 0,
5659                                                 newGVOP(OP_GV, 0, gv))));
5660             }
5661             /* we created the ops in lex_op, so make yylval.ival a null op */
5662             yylval.ival = OP_NULL;
5663         }
5664
5665         /* If it's none of the above, it must be a literal filehandle
5666            (<Foo::BAR> or <FOO>) so build a simple readline OP */
5667         else {
5668             GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO);
5669             PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv));
5670             yylval.ival = OP_NULL;
5671         }
5672     }
5673
5674     return s;
5675 }
5676
5677
5678 /* scan_str
5679    takes: start position in buffer
5680    returns: position to continue reading from buffer
5681    side-effects: multi_start, multi_close, lex_repl or lex_stuff, and
5682         updates the read buffer.
5683
5684    This subroutine pulls a string out of the input.  It is called for:
5685         q               single quotes           q(literal text)
5686         '               single quotes           'literal text'
5687         qq              double quotes           qq(interpolate $here please)
5688         "               double quotes           "interpolate $here please"
5689         qx              backticks               qx(/bin/ls -l)
5690         `               backticks               `/bin/ls -l`
5691         qw              quote words             @EXPORT_OK = qw( func() $spam )
5692         m//             regexp match            m/this/
5693         s///            regexp substitute       s/this/that/
5694         tr///           string transliterate    tr/this/that/
5695         y///            string transliterate    y/this/that/
5696         ($*@)           sub prototypes          sub foo ($)
5697         <>              readline or globs       <FOO>, <>, <$fh>, or <*.c>
5698
5699    In most of these cases (all but <>, patterns and transliterate)
5700    yylex() calls scan_str().  m// makes yylex() call scan_pat() which
5701    calls scan_str().  s/// makes yylex() call scan_subst() which calls
5702    scan_str().  tr/// and y/// make yylex() call scan_trans() which
5703    calls scan_str().
5704
5705    It skips whitespace before the string starts, and treats the first
5706    character as the delimiter.  If the delimiter is one of ([{< then
5707    the corresponding "close" character )]}> is used as the closing
5708    delimiter.  It allows quoting of delimiters, and if the string has
5709    balanced delimiters ([{<>}]) it allows nesting.
5710
5711    The lexer always reads these strings into lex_stuff, except in the
5712    case of the operators which take *two* arguments (s/// and tr///)
5713    when it checks to see if lex_stuff is full (presumably with the 1st
5714    arg to s or tr) and if so puts the string into lex_repl.
5715
5716 */
5717
5718 STATIC char *
5719 scan_str(char *start)
5720 {
5721     dTHR;
5722     SV *sv;                             /* scalar value: string */
5723     char *tmps;                         /* temp string, used for delimiter matching */
5724     register char *s = start;           /* current position in the buffer */
5725     register char term;                 /* terminating character */
5726     register char *to;                  /* current position in the sv's data */
5727     I32 brackets = 1;                   /* bracket nesting level */
5728
5729     /* skip space before the delimiter */
5730     if (isSPACE(*s))
5731         s = skipspace(s);
5732
5733     /* mark where we are, in case we need to report errors */
5734     CLINE;
5735
5736     /* after skipping whitespace, the next character is the terminator */
5737     term = *s;
5738     /* mark where we are */
5739     PL_multi_start = PL_curcop->cop_line;
5740     PL_multi_open = term;
5741
5742     /* find corresponding closing delimiter */
5743     if (term && (tmps = strchr("([{< )]}> )]}>",term)))
5744         term = tmps[5];
5745     PL_multi_close = term;
5746
5747     /* create a new SV to hold the contents.  87 is leak category, I'm
5748        assuming.  79 is the SV's initial length.  What a random number. */
5749     sv = NEWSV(87,79);
5750     sv_upgrade(sv, SVt_PVIV);
5751     SvIVX(sv) = term;
5752     (void)SvPOK_only(sv);               /* validate pointer */
5753
5754     /* move past delimiter and try to read a complete string */
5755     s++;
5756     for (;;) {
5757         /* extend sv if need be */
5758         SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1);
5759         /* set 'to' to the next character in the sv's string */
5760         to = SvPVX(sv)+SvCUR(sv);
5761
5762         /* if open delimiter is the close delimiter read unbridle */
5763         if (PL_multi_open == PL_multi_close) {
5764             for (; s < PL_bufend; s++,to++) {
5765                 /* embedded newlines increment the current line number */
5766                 if (*s == '\n' && !PL_rsfp)
5767                     PL_curcop->cop_line++;
5768                 /* handle quoted delimiters */
5769                 if (*s == '\\' && s+1 < PL_bufend && term != '\\') {
5770                     if (s[1] == term)
5771                         s++;
5772                 /* any other quotes are simply copied straight through */
5773                     else
5774                         *to++ = *s++;
5775                 }
5776                 /* terminate when run out of buffer (the for() condition), or
5777                    have found the terminator */
5778                 else if (*s == term)
5779                     break;
5780                 *to = *s;
5781             }
5782         }
5783
5784         /* if the terminator isn't the same as the start character (e.g.,
5785            matched brackets), we have to allow more in the quoting, and
5786            be prepared for nested brackets.
5787         */
5788         else {
5789             /* read until we run out of string, or we find the terminator */
5790             for (; s < PL_bufend; s++,to++) {
5791                 /* embedded newlines increment the line count */
5792                 if (*s == '\n' && !PL_rsfp)
5793                     PL_curcop->cop_line++;
5794                 /* backslashes can escape the open or closing characters */
5795                 if (*s == '\\' && s+1 < PL_bufend) {
5796                     if ((s[1] == PL_multi_open) || (s[1] == PL_multi_close))
5797                         s++;
5798                     else
5799                         *to++ = *s++;
5800                 }
5801                 /* allow nested opens and closes */
5802                 else if (*s == PL_multi_close && --brackets <= 0)
5803                     break;
5804                 else if (*s == PL_multi_open)
5805                     brackets++;
5806                 *to = *s;
5807             }
5808         }
5809         /* terminate the copied string and update the sv's end-of-string */
5810         *to = '\0';
5811         SvCUR_set(sv, to - SvPVX(sv));
5812
5813         /*
5814          * this next chunk reads more into the buffer if we're not done yet
5815          */
5816
5817         if (s < PL_bufend) break;       /* handle case where we are done yet :-) */
5818
5819 #ifndef PERL_STRICT_CR
5820         if (to - SvPVX(sv) >= 2) {
5821             if ((to[-2] == '\r' && to[-1] == '\n') ||
5822                 (to[-2] == '\n' && to[-1] == '\r'))
5823             {
5824                 to[-2] = '\n';
5825                 to--;
5826                 SvCUR_set(sv, to - SvPVX(sv));
5827             }
5828             else if (to[-1] == '\r')
5829                 to[-1] = '\n';
5830         }
5831         else if (to - SvPVX(sv) == 1 && to[-1] == '\r')
5832             to[-1] = '\n';
5833 #endif
5834
5835         /* if we're out of file, or a read fails, bail and reset the current
5836            line marker so we can report where the unterminated string began
5837         */
5838         if (!PL_rsfp ||
5839          !(PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = filter_gets(PL_linestr, PL_rsfp, 0))) {
5840             sv_free(sv);
5841             PL_curcop->cop_line = PL_multi_start;
5842             return Nullch;
5843         }
5844         /* we read a line, so increment our line counter */
5845         PL_curcop->cop_line++;
5846
5847         /* update debugger info */
5848         if (PERLDB_LINE && PL_curstash != PL_debstash) {
5849             SV *sv = NEWSV(88,0);
5850
5851             sv_upgrade(sv, SVt_PVMG);
5852             sv_setsv(sv,PL_linestr);
5853             av_store(GvAV(PL_curcop->cop_filegv),
5854               (I32)PL_curcop->cop_line, sv);
5855         }
5856
5857         /* having changed the buffer, we must update PL_bufend */
5858         PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
5859     }
5860
5861     /* at this point, we have successfully read the delimited string */
5862
5863     PL_multi_end = PL_curcop->cop_line;
5864     s++;
5865
5866     /* if we allocated too much space, give some back */
5867     if (SvCUR(sv) + 5 < SvLEN(sv)) {
5868         SvLEN_set(sv, SvCUR(sv) + 1);
5869         Renew(SvPVX(sv), SvLEN(sv), char);
5870     }
5871
5872     /* decide whether this is the first or second quoted string we've read
5873        for this op
5874     */
5875
5876     if (PL_lex_stuff)
5877         PL_lex_repl = sv;
5878     else
5879         PL_lex_stuff = sv;
5880     return s;
5881 }
5882
5883 /*
5884   scan_num
5885   takes: pointer to position in buffer
5886   returns: pointer to new position in buffer
5887   side-effects: builds ops for the constant in yylval.op
5888
5889   Read a number in any of the formats that Perl accepts:
5890
5891   0(x[0-7A-F]+)|([0-7]+)
5892   [\d_]+(\.[\d_]*)?[Ee](\d+)
5893
5894   Underbars (_) are allowed in decimal numbers.  If -w is on,
5895   underbars before a decimal point must be at three digit intervals.
5896
5897   Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the
5898   thing it reads.
5899
5900   If it reads a number without a decimal point or an exponent, it will
5901   try converting the number to an integer and see if it can do so
5902   without loss of precision.
5903 */
5904
5905 char *
5906 scan_num(char *start)
5907 {
5908     register char *s = start;           /* current position in buffer */
5909     register char *d;                   /* destination in temp buffer */
5910     register char *e;                   /* end of temp buffer */
5911     I32 tryiv;                          /* used to see if it can be an int */
5912     double value;                       /* number read, as a double */
5913     SV *sv;                             /* place to put the converted number */
5914     I32 floatit;                        /* boolean: int or float? */
5915     char *lastub = 0;                   /* position of last underbar */
5916     static char number_too_long[] = "Number too long";
5917
5918     /* We use the first character to decide what type of number this is */
5919
5920     switch (*s) {
5921     default:
5922       croak("panic: scan_num");
5923
5924     /* if it starts with a 0, it could be an octal number, a decimal in
5925        0.13 disguise, or a hexadecimal number.
5926     */
5927     case '0':
5928         {
5929           /* variables:
5930              u          holds the "number so far"
5931              shift      the power of 2 of the base (hex == 4, octal == 3)
5932              overflowed was the number more than we can hold?
5933
5934              Shift is used when we add a digit.  It also serves as an "are
5935              we in octal or hex?" indicator to disallow hex characters when
5936              in octal mode.
5937            */
5938             UV u;
5939             I32 shift;
5940             bool overflowed = FALSE;
5941
5942             /* check for hex */
5943             if (s[1] == 'x') {
5944                 shift = 4;
5945                 s += 2;
5946             }
5947             /* check for a decimal in disguise */
5948             else if (s[1] == '.')
5949                 goto decimal;
5950             /* so it must be octal */
5951             else
5952                 shift = 3;
5953             u = 0;
5954
5955             /* read the rest of the octal number */
5956             for (;;) {
5957                 UV n, b;        /* n is used in the overflow test, b is the digit we're adding on */
5958
5959                 switch (*s) {
5960
5961                 /* if we don't mention it, we're done */
5962                 default:
5963                     goto out;
5964
5965                 /* _ are ignored */
5966                 case '_':
5967                     s++;
5968                     break;
5969
5970                 /* 8 and 9 are not octal */
5971                 case '8': case '9':
5972                     if (shift != 4)
5973                         yyerror("Illegal octal digit");
5974                     /* FALL THROUGH */
5975
5976                 /* octal digits */
5977                 case '0': case '1': case '2': case '3': case '4':
5978                 case '5': case '6': case '7':
5979                     b = *s++ & 15;              /* ASCII digit -> value of digit */
5980                     goto digit;
5981
5982                 /* hex digits */
5983                 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
5984                 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
5985                     /* make sure they said 0x */
5986                     if (shift != 4)
5987                         goto out;
5988                     b = (*s++ & 7) + 9;
5989
5990                     /* Prepare to put the digit we have onto the end
5991                        of the number so far.  We check for overflows.
5992                     */
5993
5994                   digit:
5995                     n = u << shift;     /* make room for the digit */
5996                     if (!overflowed && (n >> shift) != u
5997                         && !(PL_hints & HINT_NEW_BINARY)) {
5998                         warn("Integer overflow in %s number",
5999                              (shift == 4) ? "hex" : "octal");
6000                         overflowed = TRUE;
6001                     }
6002                     u = n | b;          /* add the digit to the end */
6003                     break;
6004                 }
6005             }
6006
6007           /* if we get here, we had success: make a scalar value from
6008              the number.
6009           */
6010           out:
6011             sv = NEWSV(92,0);
6012             sv_setuv(sv, u);
6013             if ( PL_hints & HINT_NEW_BINARY)
6014                 sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL);
6015         }
6016         break;
6017
6018     /*
6019       handle decimal numbers.
6020       we're also sent here when we read a 0 as the first digit
6021     */
6022     case '1': case '2': case '3': case '4': case '5':
6023     case '6': case '7': case '8': case '9': case '.':
6024       decimal:
6025         d = PL_tokenbuf;
6026         e = PL_tokenbuf + sizeof PL_tokenbuf - 6; /* room for various punctuation */
6027         floatit = FALSE;
6028
6029         /* read next group of digits and _ and copy into d */
6030         while (isDIGIT(*s) || *s == '_') {
6031             /* skip underscores, checking for misplaced ones
6032                if -w is on
6033             */
6034             if (*s == '_') {
6035                 dTHR;                   /* only for ckWARN */
6036                 if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
6037                     warner(WARN_SYNTAX, "Misplaced _ in number");
6038                 lastub = ++s;
6039             }
6040             else {
6041                 /* check for end of fixed-length buffer */
6042                 if (d >= e)
6043                     croak(number_too_long);
6044                 /* if we're ok, copy the character */
6045                 *d++ = *s++;
6046             }
6047         }
6048
6049         /* final misplaced underbar check */
6050         if (lastub && s - lastub != 3) {
6051             dTHR;
6052             if (ckWARN(WARN_SYNTAX))
6053                 warner(WARN_SYNTAX, "Misplaced _ in number");
6054         }
6055
6056         /* read a decimal portion if there is one.  avoid
6057            3..5 being interpreted as the number 3. followed
6058            by .5
6059         */
6060         if (*s == '.' && s[1] != '.') {
6061             floatit = TRUE;
6062             *d++ = *s++;
6063
6064             /* copy, ignoring underbars, until we run out of
6065                digits.  Note: no misplaced underbar checks!
6066             */
6067             for (; isDIGIT(*s) || *s == '_'; s++) {
6068                 /* fixed length buffer check */
6069                 if (d >= e)
6070                     croak(number_too_long);
6071                 if (*s != '_')
6072                     *d++ = *s;
6073             }
6074         }
6075
6076         /* read exponent part, if present */
6077         if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) {
6078             floatit = TRUE;
6079             s++;
6080
6081             /* regardless of whether user said 3E5 or 3e5, use lower 'e' */
6082             *d++ = 'e';         /* At least some Mach atof()s don't grok 'E' */
6083
6084             /* allow positive or negative exponent */
6085             if (*s == '+' || *s == '-')
6086                 *d++ = *s++;
6087
6088             /* read digits of exponent (no underbars :-) */
6089             while (isDIGIT(*s)) {
6090                 if (d >= e)
6091                     croak(number_too_long);
6092                 *d++ = *s++;
6093             }
6094         }
6095
6096         /* terminate the string */
6097         *d = '\0';
6098
6099         /* make an sv from the string */
6100         sv = NEWSV(92,0);
6101         /* reset numeric locale in case we were earlier left in Swaziland */
6102         SET_NUMERIC_STANDARD();
6103         value = atof(PL_tokenbuf);
6104
6105         /*
6106            See if we can make do with an integer value without loss of
6107            precision.  We use I_V to cast to an int, because some
6108            compilers have issues.  Then we try casting it back and see
6109            if it was the same.  We only do this if we know we
6110            specifically read an integer.
6111
6112            Note: if floatit is true, then we don't need to do the
6113            conversion at all.
6114         */
6115         tryiv = I_V(value);
6116         if (!floatit && (double)tryiv == value)
6117             sv_setiv(sv, tryiv);
6118         else
6119             sv_setnv(sv, value);
6120         if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) )
6121             sv = new_constant(PL_tokenbuf, d - PL_tokenbuf,
6122                               (floatit ? "float" : "integer"), sv, Nullsv, NULL);
6123         break;
6124     }
6125
6126     /* make the op for the constant and return */
6127
6128     yylval.opval = newSVOP(OP_CONST, 0, sv);
6129
6130     return s;
6131 }
6132
6133 STATIC char *
6134 scan_formline(register char *s)
6135 {
6136     dTHR;
6137     register char *eol;
6138     register char *t;
6139     SV *stuff = newSVpv("",0);
6140     bool needargs = FALSE;
6141
6142     while (!needargs) {
6143         if (*s == '.' || *s == '}') {
6144             /*SUPPRESS 530*/
6145 #ifdef PERL_STRICT_CR
6146             for (t = s+1;*t == ' ' || *t == '\t'; t++) ;
6147 #else
6148             for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
6149 #endif
6150             if (*t == '\n')
6151                 break;
6152         }
6153         if (PL_in_eval && !PL_rsfp) {
6154             eol = strchr(s,'\n');
6155             if (!eol++)
6156                 eol = PL_bufend;
6157         }
6158         else
6159             eol = PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6160         if (*s != '#') {
6161             for (t = s; t < eol; t++) {
6162                 if (*t == '~' && t[1] == '~' && SvCUR(stuff)) {
6163                     needargs = FALSE;
6164                     goto enough;        /* ~~ must be first line in formline */
6165                 }
6166                 if (*t == '@' || *t == '^')
6167                     needargs = TRUE;
6168             }
6169             sv_catpvn(stuff, s, eol-s);
6170         }
6171         s = eol;
6172         if (PL_rsfp) {
6173             s = filter_gets(PL_linestr, PL_rsfp, 0);
6174             PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr);
6175             PL_bufend = PL_bufptr + SvCUR(PL_linestr);
6176             if (!s) {
6177                 s = PL_bufptr;
6178                 yyerror("Format not terminated");
6179                 break;
6180             }
6181         }
6182         incline(s);
6183     }
6184   enough:
6185     if (SvCUR(stuff)) {
6186         PL_expect = XTERM;
6187         if (needargs) {
6188             PL_lex_state = LEX_NORMAL;
6189             PL_nextval[PL_nexttoke].ival = 0;
6190             force_next(',');
6191         }
6192         else
6193             PL_lex_state = LEX_FORMLINE;
6194         PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff);
6195         force_next(THING);
6196         PL_nextval[PL_nexttoke].ival = OP_FORMLINE;
6197         force_next(LSTOP);
6198     }
6199     else {
6200         SvREFCNT_dec(stuff);
6201         PL_lex_formbrack = 0;
6202         PL_bufptr = s;
6203     }
6204     return s;
6205 }
6206
6207 STATIC void
6208 set_csh(void)
6209 {
6210 #ifdef CSH
6211     if (!PL_cshlen)
6212         PL_cshlen = strlen(PL_cshname);
6213 #endif
6214 }
6215
6216 I32
6217 start_subparse(I32 is_format, U32 flags)
6218 {
6219     dTHR;
6220     I32 oldsavestack_ix = PL_savestack_ix;
6221     CV* outsidecv = PL_compcv;
6222     AV* comppadlist;
6223
6224     if (PL_compcv) {
6225         assert(SvTYPE(PL_compcv) == SVt_PVCV);
6226     }
6227     save_I32(&PL_subline);
6228     save_item(PL_subname);
6229     SAVEI32(PL_padix);
6230     SAVESPTR(PL_curpad);
6231     SAVESPTR(PL_comppad);
6232     SAVESPTR(PL_comppad_name);
6233     SAVESPTR(PL_compcv);
6234     SAVEI32(PL_comppad_name_fill);
6235     SAVEI32(PL_min_intro_pending);
6236     SAVEI32(PL_max_intro_pending);
6237     SAVEI32(PL_pad_reset_pending);
6238
6239     PL_compcv = (CV*)NEWSV(1104,0);
6240     sv_upgrade((SV *)PL_compcv, is_format ? SVt_PVFM : SVt_PVCV);
6241     CvFLAGS(PL_compcv) |= flags;
6242
6243     PL_comppad = newAV();
6244     av_push(PL_comppad, Nullsv);
6245     PL_curpad = AvARRAY(PL_comppad);
6246     PL_comppad_name = newAV();
6247     PL_comppad_name_fill = 0;
6248     PL_min_intro_pending = 0;
6249     PL_padix = 0;
6250     PL_subline = PL_curcop->cop_line;
6251 #ifdef USE_THREADS
6252     av_store(PL_comppad_name, 0, newSVpv("@_", 2));
6253     PL_curpad[0] = (SV*)newAV();
6254     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
6255 #endif /* USE_THREADS */
6256
6257     comppadlist = newAV();
6258     AvREAL_off(comppadlist);
6259     av_store(comppadlist, 0, (SV*)PL_comppad_name);
6260     av_store(comppadlist, 1, (SV*)PL_comppad);
6261
6262     CvPADLIST(PL_compcv) = comppadlist;
6263     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv);
6264 #ifdef USE_THREADS
6265     CvOWNER(PL_compcv) = 0;
6266     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
6267     MUTEX_INIT(CvMUTEXP(PL_compcv));
6268 #endif /* USE_THREADS */
6269
6270     return oldsavestack_ix;
6271 }
6272
6273 int
6274 yywarn(char *s)
6275 {
6276     dTHR;
6277     --PL_error_count;
6278     PL_in_eval |= 2;
6279     yyerror(s);
6280     PL_in_eval &= ~2;
6281     return 0;
6282 }
6283
6284 int
6285 yyerror(char *s)
6286 {
6287     dTHR;
6288     char *where = NULL;
6289     char *context = NULL;
6290     int contlen = -1;
6291     SV *msg;
6292
6293     if (!yychar || (yychar == ';' && !PL_rsfp))
6294         where = "at EOF";
6295     else if (PL_bufptr > PL_oldoldbufptr && PL_bufptr - PL_oldoldbufptr < 200 &&
6296       PL_oldoldbufptr != PL_oldbufptr && PL_oldbufptr != PL_bufptr) {
6297         while (isSPACE(*PL_oldoldbufptr))
6298             PL_oldoldbufptr++;
6299         context = PL_oldoldbufptr;
6300         contlen = PL_bufptr - PL_oldoldbufptr;
6301     }
6302     else if (PL_bufptr > PL_oldbufptr && PL_bufptr - PL_oldbufptr < 200 &&
6303       PL_oldbufptr != PL_bufptr) {
6304         while (isSPACE(*PL_oldbufptr))
6305             PL_oldbufptr++;
6306         context = PL_oldbufptr;
6307         contlen = PL_bufptr - PL_oldbufptr;
6308     }
6309     else if (yychar > 255)
6310         where = "next token ???";
6311     else if ((yychar & 127) == 127) {
6312         if (PL_lex_state == LEX_NORMAL ||
6313            (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL))
6314             where = "at end of line";
6315         else if (PL_lex_inpat)
6316             where = "within pattern";
6317         else
6318             where = "within string";
6319     }
6320     else {
6321         SV *where_sv = sv_2mortal(newSVpv("next char ", 0));
6322         if (yychar < 32)
6323             sv_catpvf(where_sv, "^%c", toCTRL(yychar));
6324         else if (isPRINT_LC(yychar))
6325             sv_catpvf(where_sv, "%c", yychar);
6326         else
6327             sv_catpvf(where_sv, "\\%03o", yychar & 255);
6328         where = SvPVX(where_sv);
6329     }
6330     msg = sv_2mortal(newSVpv(s, 0));
6331     sv_catpvf(msg, " at %_ line %ld, ",
6332               GvSV(PL_curcop->cop_filegv), (long)PL_curcop->cop_line);
6333     if (context)
6334         sv_catpvf(msg, "near \"%.*s\"\n", contlen, context);
6335     else
6336         sv_catpvf(msg, "%s\n", where);
6337     if (PL_multi_start < PL_multi_end && (U32)(PL_curcop->cop_line - PL_multi_end) <= 1) {
6338         sv_catpvf(msg,
6339         "  (Might be a runaway multi-line %c%c string starting on line %ld)\n",
6340                 (int)PL_multi_open,(int)PL_multi_close,(long)PL_multi_start);
6341         PL_multi_end = 0;
6342     }
6343     if (PL_in_eval & 2)
6344         warn("%_", msg);
6345     else if (PL_in_eval)
6346         sv_catsv(ERRSV, msg);
6347     else
6348         PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg));
6349     if (++PL_error_count >= 10)
6350         croak("%_ has too many errors.\n", GvSV(PL_curcop->cop_filegv));
6351     PL_in_my = 0;
6352     PL_in_my_stash = Nullhv;
6353     return 0;
6354 }
6355
6356