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