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