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