contrib/perl5/toke.c

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