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