toke.c

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