toke.c

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