pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (c) 1991-2002, 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  * Now far ahead the Road has gone,
  12  * And I must follow, if I can,
  13  * Pursuing it with eager feet,
  14  * Until it joins some larger way
  15  * Where many paths and errands meet.
  16  * And whither then?  I cannot say.
  17  */
  18
  19 #include "EXTERN.h"
  20 #define PERL_IN_PP_CTL_C
  21 #include "perl.h"
  22
  23 #ifndef WORD_ALIGN
  24 #define WORD_ALIGN sizeof(U16)
  25 #endif
  26
  27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  28
  29 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
  30
  31 PP(pp_wantarray)
  32 {
  33     dSP;
  34     I32 cxix;
  35     EXTEND(SP, 1);
  36
  37     cxix = dopoptosub(cxstack_ix);
  38     if (cxix < 0)
  39         RETPUSHUNDEF;
  40
  41     switch (cxstack[cxix].blk_gimme) {
  42     case G_ARRAY:
  43         RETPUSHYES;
  44     case G_SCALAR:
  45         RETPUSHNO;
  46     default:
  47         RETPUSHUNDEF;
  48     }
  49 }
  50
  51 PP(pp_regcmaybe)
  52 {
  53     return NORMAL;
  54 }
  55
  56 PP(pp_regcreset)
  57 {
  58     /* XXXX Should store the old value to allow for tie/overload - and
  59        restore in regcomp, where marked with XXXX. */
  60     PL_reginterp_cnt = 0;
  61     return NORMAL;
  62 }
  63
  64 PP(pp_regcomp)
  65 {
  66     dSP;
  67     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  68     register char *t;
  69     SV *tmpstr;
  70     STRLEN len;
  71     MAGIC *mg = Null(MAGIC*);
  72
  73     tmpstr = POPs;
  74
  75     /* prevent recompiling under /o and ithreads. */
  76 #if defined(USE_ITHREADS)
  77     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
  78          RETURN;
  79 #endif
  80
  81     if (SvROK(tmpstr)) {
  82         SV *sv = SvRV(tmpstr);
  83         if(SvMAGICAL(sv))
  84             mg = mg_find(sv, PERL_MAGIC_qr);
  85     }
  86     if (mg) {
  87         regexp *re = (regexp *)mg->mg_obj;
  88         ReREFCNT_dec(PM_GETRE(pm));
  89         PM_SETRE(pm, ReREFCNT_inc(re));
  90     }
  91     else {
  92         t = SvPV(tmpstr, len);
  93
  94         /* Check against the last compiled regexp. */
  95         if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
  96             PM_GETRE(pm)->prelen != (I32)len ||
  97             memNE(PM_GETRE(pm)->precomp, t, len))
  98         {
  99             if (PM_GETRE(pm)) {
 100                 ReREFCNT_dec(PM_GETRE(pm));
 101                 PM_SETRE(pm, Null(REGEXP*));    /* crucial if regcomp aborts */
 102             }
 103             if (PL_op->op_flags & OPf_SPECIAL)
 104                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 105
 106             pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
 107             if (DO_UTF8(tmpstr))
 108                 pm->op_pmdynflags |= PMdf_DYN_UTF8;
 109             else {
 110                 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
 111                 if (pm->op_pmdynflags & PMdf_UTF8)
 112                     t = (char*)bytes_to_utf8((U8*)t, &len);
 113             }
 114             PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
 115             if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
 116                 Safefree(t);
 117             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
 118                                            inside tie/overload accessors.  */
 119         }
 120     }
 121
 122 #ifndef INCOMPLETE_TAINTS
 123     if (PL_tainting) {
 124         if (PL_tainted)
 125             pm->op_pmdynflags |= PMdf_TAINTED;
 126         else
 127             pm->op_pmdynflags &= ~PMdf_TAINTED;
 128     }
 129 #endif
 130
 131     if (!PM_GETRE(pm)->prelen && PL_curpm)
 132         pm = PL_curpm;
 133     else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
 134         pm->op_pmflags |= PMf_WHITE;
 135     else
 136         pm->op_pmflags &= ~PMf_WHITE;
 137
 138     /* XXX runtime compiled output needs to move to the pad */
 139     if (pm->op_pmflags & PMf_KEEP) {
 140         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 141 #if !defined(USE_ITHREADS)
 142         /* XXX can't change the optree at runtime either */
 143         cLOGOP->op_first->op_next = PL_op->op_next;
 144 #endif
 145     }
 146     RETURN;
 147 }
 148
 149 PP(pp_substcont)
 150 {
 151     dSP;
 152     register PMOP *pm = (PMOP*) cLOGOP->op_other;
 153     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 154     register SV *dstr = cx->sb_dstr;
 155     register char *s = cx->sb_s;
 156     register char *m = cx->sb_m;
 157     char *orig = cx->sb_orig;
 158     register REGEXP *rx = cx->sb_rx;
 159     SV *nsv = Nullsv;
 160
 161     rxres_restore(&cx->sb_rxres, rx);
 162     RX_MATCH_UTF8_set(rx, SvUTF8(cx->sb_targ));
 163
 164     if (cx->sb_iters++) {
 165         I32 saviters = cx->sb_iters;
 166         if (cx->sb_iters > cx->sb_maxiters)
 167             DIE(aTHX_ "Substitution loop");
 168
 169         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 170             cx->sb_rxtainted |= 2;
 171         sv_catsv(dstr, POPs);
 172
 173         /* Are we done */
 174         if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
 175                                      s == m, cx->sb_targ, NULL,
 176                                      ((cx->sb_rflags & REXEC_COPY_STR)
 177                                       ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 178                                       : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 179         {
 180             SV *targ = cx->sb_targ;
 181
 182             if (DO_UTF8(dstr) && !SvUTF8(targ))
 183                 sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 184             else
 185                 sv_catpvn(dstr, s, cx->sb_strend - s);
 186             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 187
 188 #ifdef PERL_COPY_ON_WRITE
 189             if (SvIsCOW(targ)) {
 190                 sv_force_normal_flags(targ, SV_COW_DROP_PV);
 191             } else
 192 #endif
 193             {
 194                 (void)SvOOK_off(targ);
 195                 if (SvLEN(targ))
 196                     Safefree(SvPVX(targ));
 197             }
 198             SvPVX(targ) = SvPVX(dstr);
 199             SvCUR_set(targ, SvCUR(dstr));
 200             SvLEN_set(targ, SvLEN(dstr));
 201             if (DO_UTF8(dstr))
 202                 SvUTF8_on(targ);
 203             SvPVX(dstr) = 0;
 204             sv_free(dstr);
 205
 206             TAINT_IF(cx->sb_rxtainted & 1);
 207             PUSHs(sv_2mortal(newSViv(saviters - 1)));
 208
 209             (void)SvPOK_only_UTF8(targ);
 210             TAINT_IF(cx->sb_rxtainted);
 211             SvSETMAGIC(targ);
 212             SvTAINT(targ);
 213
 214             LEAVE_SCOPE(cx->sb_oldsave);
 215             POPSUBST(cx);
 216             RETURNOP(pm->op_next);
 217         }
 218         cx->sb_iters = saviters;
 219     }
 220     if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
 221         m = s;
 222         s = orig;
 223         cx->sb_orig = orig = rx->subbeg;
 224         s = orig + (m - s);
 225         cx->sb_strend = s + (cx->sb_strend - m);
 226     }
 227     cx->sb_m = m = rx->startp[0] + orig;
 228     if (m > s) {
 229         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 230             sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
 231         else
 232             sv_catpvn(dstr, s, m-s);
 233     }
 234     cx->sb_s = rx->endp[0] + orig;
 235     { /* Update the pos() information. */
 236         SV *sv = cx->sb_targ;
 237         MAGIC *mg;
 238         I32 i;
 239         if (SvTYPE(sv) < SVt_PVMG)
 240             (void)SvUPGRADE(sv, SVt_PVMG);
 241         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 242             sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
 243             mg = mg_find(sv, PERL_MAGIC_regex_global);
 244         }
 245         i = m - orig;
 246         if (DO_UTF8(sv))
 247             sv_pos_b2u(sv, &i);
 248         mg->mg_len = i;
 249     }
 250     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 251     rxres_save(&cx->sb_rxres, rx);
 252     RETURNOP(pm->op_pmreplstart);
 253 }
 254
 255 void
 256 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 257 {
 258     UV *p = (UV*)*rsp;
 259     U32 i;
 260
 261     if (!p || p[1] < rx->nparens) {
 262 #ifdef PERL_COPY_ON_WRITE
 263         i = 7 + rx->nparens * 2;
 264 #else
 265         i = 6 + rx->nparens * 2;
 266 #endif
 267         if (!p)
 268             New(501, p, i, UV);
 269         else
 270             Renew(p, i, UV);
 271         *rsp = (void*)p;
 272     }
 273
 274     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
 275     RX_MATCH_COPIED_off(rx);
 276
 277 #ifdef PERL_COPY_ON_WRITE
 278     *p++ = PTR2UV(rx->saved_copy);
 279     rx->saved_copy = Nullsv;
 280 #endif
 281
 282     *p++ = rx->nparens;
 283
 284     *p++ = PTR2UV(rx->subbeg);
 285     *p++ = (UV)rx->sublen;
 286     for (i = 0; i <= rx->nparens; ++i) {
 287         *p++ = (UV)rx->startp[i];
 288         *p++ = (UV)rx->endp[i];
 289     }
 290 }
 291
 292 void
 293 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 294 {
 295     UV *p = (UV*)*rsp;
 296     U32 i;
 297
 298     RX_MATCH_COPY_FREE(rx);
 299     RX_MATCH_COPIED_set(rx, *p);
 300     *p++ = 0;
 301
 302 #ifdef PERL_COPY_ON_WRITE
 303     if (rx->saved_copy)
 304         SvREFCNT_dec (rx->saved_copy);
 305     rx->saved_copy = INT2PTR(SV*,*p);
 306     *p++ = 0;
 307 #endif
 308
 309     rx->nparens = *p++;
 310
 311     rx->subbeg = INT2PTR(char*,*p++);
 312     rx->sublen = (I32)(*p++);
 313     for (i = 0; i <= rx->nparens; ++i) {
 314         rx->startp[i] = (I32)(*p++);
 315         rx->endp[i] = (I32)(*p++);
 316     }
 317 }
 318
 319 void
 320 Perl_rxres_free(pTHX_ void **rsp)
 321 {
 322     UV *p = (UV*)*rsp;
 323
 324     if (p) {
 325         Safefree(INT2PTR(char*,*p));
 326 #ifdef PERL_COPY_ON_WRITE
 327         if (p[1]) {
 328             SvREFCNT_dec (INT2PTR(SV*,p[1]));
 329         }
 330 #endif
 331         Safefree(p);
 332         *rsp = Null(void*);
 333     }
 334 }
 335
 336 PP(pp_formline)
 337 {
 338     dSP; dMARK; dORIGMARK;
 339     register SV *tmpForm = *++MARK;
 340     register U16 *fpc;
 341     register char *t;
 342     register char *f;
 343     register char *s;
 344     register char *send;
 345     register I32 arg;
 346     register SV *sv = Nullsv;
 347     char *item = Nullch;
 348     I32 itemsize  = 0;
 349     I32 fieldsize = 0;
 350     I32 lines = 0;
 351     bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
 352     char *chophere = Nullch;
 353     char *linemark = Nullch;
 354     NV value;
 355     bool gotsome = FALSE;
 356     STRLEN len;
 357     STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
 358     bool item_is_utf8 = FALSE;
 359     bool targ_is_utf8 = FALSE;
 360     SV * nsv = Nullsv;
 361
 362     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 363         if (SvREADONLY(tmpForm)) {
 364             SvREADONLY_off(tmpForm);
 365             doparseform(tmpForm);
 366             SvREADONLY_on(tmpForm);
 367         }
 368         else
 369             doparseform(tmpForm);
 370     }
 371     SvPV_force(PL_formtarget, len);
 372     if (DO_UTF8(PL_formtarget))
 373         targ_is_utf8 = TRUE;
 374     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 375     t += len;
 376     f = SvPV(tmpForm, len);
 377     /* need to jump to the next word */
 378     s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
 379
 380     fpc = (U16*)s;
 381
 382     for (;;) {
 383         DEBUG_f( {
 384             char *name = "???";
 385             arg = -1;
 386             switch (*fpc) {
 387             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 388             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 389             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 390             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 391             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 392
 393             case FF_CHECKNL:    name = "CHECKNL";       break;
 394             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 395             case FF_SPACE:      name = "SPACE";         break;
 396             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 397             case FF_ITEM:       name = "ITEM";          break;
 398             case FF_CHOP:       name = "CHOP";          break;
 399             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 400             case FF_NEWLINE:    name = "NEWLINE";       break;
 401             case FF_MORE:       name = "MORE";          break;
 402             case FF_LINEMARK:   name = "LINEMARK";      break;
 403             case FF_END:        name = "END";           break;
 404             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 405             }
 406             if (arg >= 0)
 407                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 408             else
 409                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 410         } );
 411         switch (*fpc++) {
 412         case FF_LINEMARK:
 413             linemark = t;
 414             lines++;
 415             gotsome = FALSE;
 416             break;
 417
 418         case FF_LITERAL:
 419             arg = *fpc++;
 420             if (targ_is_utf8 && !SvUTF8(tmpForm)) {
 421                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 422                 *t = '\0';
 423                 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
 424                 t = SvEND(PL_formtarget);
 425                 break;
 426             }
 427             if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
 428                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 429                 *t = '\0';
 430                 sv_utf8_upgrade(PL_formtarget);
 431                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 432                 t = SvEND(PL_formtarget);
 433                 targ_is_utf8 = TRUE;
 434             }
 435             while (arg--)
 436                 *t++ = *f++;
 437             break;
 438
 439         case FF_SKIP:
 440             f += *fpc++;
 441             break;
 442
 443         case FF_FETCH:
 444             arg = *fpc++;
 445             f += arg;
 446             fieldsize = arg;
 447
 448             if (MARK < SP)
 449                 sv = *++MARK;
 450             else {
 451                 sv = &PL_sv_no;
 452                 if (ckWARN(WARN_SYNTAX))
 453                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 454             }
 455             break;
 456
 457         case FF_CHECKNL:
 458             item = s = SvPV(sv, len);
 459             itemsize = len;
 460             if (DO_UTF8(sv)) {
 461                 itemsize = sv_len_utf8(sv);
 462                 if (itemsize != (I32)len) {
 463                     I32 itembytes;
 464                     if (itemsize > fieldsize) {
 465                         itemsize = fieldsize;
 466                         itembytes = itemsize;
 467                         sv_pos_u2b(sv, &itembytes, 0);
 468                     }
 469                     else
 470                         itembytes = len;
 471                     send = chophere = s + itembytes;
 472                     while (s < send) {
 473                         if (*s & ~31)
 474                             gotsome = TRUE;
 475                         else if (*s == '\n')
 476                             break;
 477                         s++;
 478                     }
 479                     item_is_utf8 = TRUE;
 480                     itemsize = s - item;
 481                     sv_pos_b2u(sv, &itemsize);
 482                     break;
 483                 }
 484             }
 485             item_is_utf8 = FALSE;
 486             if (itemsize > fieldsize)
 487                 itemsize = fieldsize;
 488             send = chophere = s + itemsize;
 489             while (s < send) {
 490                 if (*s & ~31)
 491                     gotsome = TRUE;
 492                 else if (*s == '\n')
 493                     break;
 494                 s++;
 495             }
 496             itemsize = s - item;
 497             break;
 498
 499         case FF_CHECKCHOP:
 500             item = s = SvPV(sv, len);
 501             itemsize = len;
 502             if (DO_UTF8(sv)) {
 503                 itemsize = sv_len_utf8(sv);
 504                 if (itemsize != (I32)len) {
 505                     I32 itembytes;
 506                     if (itemsize <= fieldsize) {
 507                         send = chophere = s + itemsize;
 508                         while (s < send) {
 509                             if (*s == '\r') {
 510                                 itemsize = s - item;
 511                                 break;
 512                             }
 513                             if (*s++ & ~31)
 514                                 gotsome = TRUE;
 515                         }
 516                     }
 517                     else {
 518                         itemsize = fieldsize;
 519                         itembytes = itemsize;
 520                         sv_pos_u2b(sv, &itembytes, 0);
 521                         send = chophere = s + itembytes;
 522                         while (s < send || (s == send && isSPACE(*s))) {
 523                             if (isSPACE(*s)) {
 524                                 if (chopspace)
 525                                     chophere = s;
 526                                 if (*s == '\r')
 527                                     break;
 528                             }
 529                             else {
 530                                 if (*s & ~31)
 531                                     gotsome = TRUE;
 532                                 if (strchr(PL_chopset, *s))
 533                                     chophere = s + 1;
 534                             }
 535                             s++;
 536                         }
 537                         itemsize = chophere - item;
 538                         sv_pos_b2u(sv, &itemsize);
 539                     }
 540                     item_is_utf8 = TRUE;
 541                     break;
 542                 }
 543             }
 544             item_is_utf8 = FALSE;
 545             if (itemsize <= fieldsize) {
 546                 send = chophere = s + itemsize;
 547                 while (s < send) {
 548                     if (*s == '\r') {
 549                         itemsize = s - item;
 550                         break;
 551                     }
 552                     if (*s++ & ~31)
 553                         gotsome = TRUE;
 554                 }
 555             }
 556             else {
 557                 itemsize = fieldsize;
 558                 send = chophere = s + itemsize;
 559                 while (s < send || (s == send && isSPACE(*s))) {
 560                     if (isSPACE(*s)) {
 561                         if (chopspace)
 562                             chophere = s;
 563                         if (*s == '\r')
 564                             break;
 565                     }
 566                     else {
 567                         if (*s & ~31)
 568                             gotsome = TRUE;
 569                         if (strchr(PL_chopset, *s))
 570                             chophere = s + 1;
 571                     }
 572                     s++;
 573                 }
 574                 itemsize = chophere - item;
 575             }
 576             break;
 577
 578         case FF_SPACE:
 579             arg = fieldsize - itemsize;
 580             if (arg) {
 581                 fieldsize -= arg;
 582                 while (arg-- > 0)
 583                     *t++ = ' ';
 584             }
 585             break;
 586
 587         case FF_HALFSPACE:
 588             arg = fieldsize - itemsize;
 589             if (arg) {
 590                 arg /= 2;
 591                 fieldsize -= arg;
 592                 while (arg-- > 0)
 593                     *t++ = ' ';
 594             }
 595             break;
 596
 597         case FF_ITEM:
 598             arg = itemsize;
 599             s = item;
 600             if (item_is_utf8) {
 601                 if (!targ_is_utf8) {
 602                     SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 603                     *t = '\0';
 604                     sv_utf8_upgrade(PL_formtarget);
 605                     SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 606                     t = SvEND(PL_formtarget);
 607                     targ_is_utf8 = TRUE;
 608                 }
 609                 while (arg--) {
 610                     if (UTF8_IS_CONTINUED(*s)) {
 611                         STRLEN skip = UTF8SKIP(s);
 612                         switch (skip) {
 613                         default:
 614                             Move(s,t,skip,char);
 615                             s += skip;
 616                             t += skip;
 617                             break;
 618                         case 7: *t++ = *s++;
 619                         case 6: *t++ = *s++;
 620                         case 5: *t++ = *s++;
 621                         case 4: *t++ = *s++;
 622                         case 3: *t++ = *s++;
 623                         case 2: *t++ = *s++;
 624                         case 1: *t++ = *s++;
 625                         }
 626                     }
 627                     else {
 628                         if ( !((*t++ = *s++) & ~31) )
 629                             t[-1] = ' ';
 630                     }
 631                 }
 632                 break;
 633             }
 634             if (targ_is_utf8 && !item_is_utf8) {
 635                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 636                 *t = '\0';
 637                 sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
 638                 for (; t < SvEND(PL_formtarget); t++) {
 639 #ifdef EBCDIC
 640                     int ch = *t++ = *s++;
 641                     if (iscntrl(ch))
 642 #else
 643                     if (!(*t & ~31))
 644 #endif
 645                         *t = ' ';
 646                 }
 647                 break;
 648             }
 649             while (arg--) {
 650 #ifdef EBCDIC
 651                 int ch = *t++ = *s++;
 652                 if (iscntrl(ch))
 653 #else
 654                 if ( !((*t++ = *s++) & ~31) )
 655 #endif
 656                     t[-1] = ' ';
 657             }
 658             break;
 659
 660         case FF_CHOP:
 661             s = chophere;
 662             if (chopspace) {
 663                 while (*s && isSPACE(*s))
 664                     s++;
 665             }
 666             sv_chop(sv,s);
 667             break;
 668
 669         case FF_LINEGLOB:
 670             item = s = SvPV(sv, len);
 671             itemsize = len;
 672             if ((item_is_utf8 = DO_UTF8(sv)))
 673                 itemsize = sv_len_utf8(sv);
 674             if (itemsize) {
 675                 bool chopped = FALSE;
 676                 gotsome = TRUE;
 677                 send = s + len;
 678                 while (s < send) {
 679                     if (*s++ == '\n') {
 680                         if (s == send) {
 681                             itemsize--;
 682                             chopped = TRUE;
 683                         }
 684                         else
 685                             lines++;
 686                     }
 687                 }
 688                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 689                 if (targ_is_utf8)
 690                     SvUTF8_on(PL_formtarget);
 691                 sv_catsv(PL_formtarget, sv);
 692                 if (chopped)
 693                     SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
 694                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 695                 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 696                 if (item_is_utf8)
 697                     targ_is_utf8 = TRUE;
 698             }
 699             break;
 700
 701         case FF_DECIMAL:
 702             /* If the field is marked with ^ and the value is undefined,
 703                blank it out. */
 704             arg = *fpc++;
 705             if ((arg & 512) && !SvOK(sv)) {
 706                 arg = fieldsize;
 707                 while (arg--)
 708                     *t++ = ' ';
 709                 break;
 710             }
 711             gotsome = TRUE;
 712             value = SvNV(sv);
 713             /* Formats aren't yet marked for locales, so assume "yes". */
 714             {
 715                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 716 #if defined(USE_LONG_DOUBLE)
 717                 if (arg & 256) {
 718                     sprintf(t, "%#*.*" PERL_PRIfldbl,
 719                             (int) fieldsize, (int) arg & 255, value);
 720                 } else {
 721                     sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
 722                 }
 723 #else
 724                 if (arg & 256) {
 725                     sprintf(t, "%#*.*f",
 726                             (int) fieldsize, (int) arg & 255, value);
 727                 } else {
 728                     sprintf(t, "%*.0f",
 729                             (int) fieldsize, value);
 730                 }
 731 #endif
 732                 RESTORE_NUMERIC_STANDARD();
 733             }
 734             t += fieldsize;
 735             break;
 736
 737         case FF_0DECIMAL:
 738             /* If the field is marked with ^ and the value is undefined,
 739                blank it out. */
 740             arg = *fpc++;
 741             if ((arg & 512) && !SvOK(sv)) {
 742                 arg = fieldsize;
 743                 while (arg--)
 744                     *t++ = ' ';
 745                 break;
 746             }
 747             gotsome = TRUE;
 748             value = SvNV(sv);
 749             /* Formats aren't yet marked for locales, so assume "yes". */
 750             {
 751                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 752 #if defined(USE_LONG_DOUBLE)
 753                 if (arg & 256) {
 754                     sprintf(t, "%#0*.*" PERL_PRIfldbl,
 755                             (int) fieldsize, (int) arg & 255, value);
 756 /* is this legal? I don't have long doubles */
 757                 } else {
 758                     sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
 759                 }
 760 #else
 761                 if (arg & 256) {
 762                     sprintf(t, "%#0*.*f",
 763                             (int) fieldsize, (int) arg & 255, value);
 764                 } else {
 765                     sprintf(t, "%0*.0f",
 766                             (int) fieldsize, value);
 767                 }
 768 #endif
 769                 RESTORE_NUMERIC_STANDARD();
 770             }
 771             t += fieldsize;
 772             break;
 773
 774         case FF_NEWLINE:
 775             f++;
 776             while (t-- > linemark && *t == ' ') ;
 777             t++;
 778             *t++ = '\n';
 779             break;
 780
 781         case FF_BLANK:
 782             arg = *fpc++;
 783             if (gotsome) {
 784                 if (arg) {              /* repeat until fields exhausted? */
 785                     *t = '\0';
 786                     SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 787                     lines += FmLINES(PL_formtarget);
 788                     if (lines == 200) {
 789                         arg = t - linemark;
 790                         if (strnEQ(linemark, linemark - arg, arg))
 791                             DIE(aTHX_ "Runaway format");
 792                     }
 793                     if (targ_is_utf8)
 794                         SvUTF8_on(PL_formtarget);
 795                     FmLINES(PL_formtarget) = lines;
 796                     SP = ORIGMARK;
 797                     RETURNOP(cLISTOP->op_first);
 798                 }
 799             }
 800             else {
 801                 t = linemark;
 802                 lines--;
 803             }
 804             break;
 805
 806         case FF_MORE:
 807             s = chophere;
 808             send = item + len;
 809             if (chopspace) {
 810                 while (*s && isSPACE(*s) && s < send)
 811                     s++;
 812             }
 813             if (s < send) {
 814                 arg = fieldsize - itemsize;
 815                 if (arg) {
 816                     fieldsize -= arg;
 817                     while (arg-- > 0)
 818                         *t++ = ' ';
 819                 }
 820                 s = t - 3;
 821                 if (strnEQ(s,"   ",3)) {
 822                     while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
 823                         s--;
 824                 }
 825                 *s++ = '.';
 826                 *s++ = '.';
 827                 *s++ = '.';
 828             }
 829             break;
 830
 831         case FF_END:
 832             *t = '\0';
 833             SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 834             if (targ_is_utf8)
 835                 SvUTF8_on(PL_formtarget);
 836             FmLINES(PL_formtarget) += lines;
 837             SP = ORIGMARK;
 838             RETPUSHYES;
 839         }
 840     }
 841 }
 842
 843 PP(pp_grepstart)
 844 {
 845     dSP;
 846     SV *src;
 847
 848     if (PL_stack_base + *PL_markstack_ptr == SP) {
 849         (void)POPMARK;
 850         if (GIMME_V == G_SCALAR)
 851             XPUSHs(sv_2mortal(newSViv(0)));
 852         RETURNOP(PL_op->op_next->op_next);
 853     }
 854     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
 855     pp_pushmark();                              /* push dst */
 856     pp_pushmark();                              /* push src */
 857     ENTER;                                      /* enter outer scope */
 858
 859     SAVETMPS;
 860     /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
 861     SAVESPTR(DEFSV);
 862     ENTER;                                      /* enter inner scope */
 863     SAVEVPTR(PL_curpm);
 864
 865     src = PL_stack_base[*PL_markstack_ptr];
 866     SvTEMP_off(src);
 867     DEFSV = src;
 868
 869     PUTBACK;
 870     if (PL_op->op_type == OP_MAPSTART)
 871         pp_pushmark();                  /* push top */
 872     return ((LOGOP*)PL_op->op_next)->op_other;
 873 }
 874
 875 PP(pp_mapstart)
 876 {
 877     DIE(aTHX_ "panic: mapstart");       /* uses grepstart */
 878 }
 879
 880 PP(pp_mapwhile)
 881 {
 882     dSP;
 883     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
 884     I32 count;
 885     I32 shift;
 886     SV** src;
 887     SV** dst;
 888
 889     /* first, move source pointer to the next item in the source list */
 890     ++PL_markstack_ptr[-1];
 891
 892     /* if there are new items, push them into the destination list */
 893     if (items) {
 894         /* might need to make room back there first */
 895         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
 896             /* XXX this implementation is very pessimal because the stack
 897              * is repeatedly extended for every set of items.  Is possible
 898              * to do this without any stack extension or copying at all
 899              * by maintaining a separate list over which the map iterates
 900              * (like foreach does). --gsar */
 901
 902             /* everything in the stack after the destination list moves
 903              * towards the end the stack by the amount of room needed */
 904             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
 905
 906             /* items to shift up (accounting for the moved source pointer) */
 907             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
 908
 909             /* This optimization is by Ben Tilly and it does
 910              * things differently from what Sarathy (gsar)
 911              * is describing.  The downside of this optimization is
 912              * that leaves "holes" (uninitialized and hopefully unused areas)
 913              * to the Perl stack, but on the other hand this
 914              * shouldn't be a problem.  If Sarathy's idea gets
 915              * implemented, this optimization should become
 916              * irrelevant.  --jhi */
 917             if (shift < count)
 918                 shift = count; /* Avoid shifting too often --Ben Tilly */
 919
 920             EXTEND(SP,shift);
 921             src = SP;
 922             dst = (SP += shift);
 923             PL_markstack_ptr[-1] += shift;
 924             *PL_markstack_ptr += shift;
 925             while (count--)
 926                 *dst-- = *src--;
 927         }
 928         /* copy the new items down to the destination list */
 929         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
 930         while (items-- > 0)
 931             *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
 932     }
 933     LEAVE;                                      /* exit inner scope */
 934
 935     /* All done yet? */
 936     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
 937         I32 gimme = GIMME_V;
 938
 939         (void)POPMARK;                          /* pop top */
 940         LEAVE;                                  /* exit outer scope */
 941         (void)POPMARK;                          /* pop src */
 942         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
 943         (void)POPMARK;                          /* pop dst */
 944         SP = PL_stack_base + POPMARK;           /* pop original mark */
 945         if (gimme == G_SCALAR) {
 946             dTARGET;
 947             XPUSHi(items);
 948         }
 949         else if (gimme == G_ARRAY)
 950             SP += items;
 951         RETURN;
 952     }
 953     else {
 954         SV *src;
 955
 956         ENTER;                                  /* enter inner scope */
 957         SAVEVPTR(PL_curpm);
 958
 959         /* set $_ to the new source item */
 960         src = PL_stack_base[PL_markstack_ptr[-1]];
 961         SvTEMP_off(src);
 962         DEFSV = src;
 963
 964         RETURNOP(cLOGOP->op_other);
 965     }
 966 }
 967
 968 /* Range stuff. */
 969
 970 PP(pp_range)
 971 {
 972     if (GIMME == G_ARRAY)
 973         return NORMAL;
 974     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
 975         return cLOGOP->op_other;
 976     else
 977         return NORMAL;
 978 }
 979
 980 PP(pp_flip)
 981 {
 982     dSP;
 983
 984     if (GIMME == G_ARRAY) {
 985         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
 986     }
 987     else {
 988         dTOPss;
 989         SV *targ = PAD_SV(PL_op->op_targ);
 990         int flip = 0;
 991
 992         if (PL_op->op_private & OPpFLIP_LINENUM) {
 993             if (GvIO(PL_last_in_gv)) {
 994                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
 995             }
 996             else {
 997                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
 998                 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
 999             }
1000         } else {
1001             flip = SvTRUE(sv);
1002         }
1003         if (flip) {
1004             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1005             if (PL_op->op_flags & OPf_SPECIAL) {
1006                 sv_setiv(targ, 1);
1007                 SETs(targ);
1008                 RETURN;
1009             }
1010             else {
1011                 sv_setiv(targ, 0);
1012                 SP--;
1013                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1014             }
1015         }
1016         sv_setpv(TARG, "");
1017         SETs(targ);
1018         RETURN;
1019     }
1020 }
1021
1022 PP(pp_flop)
1023 {
1024     dSP;
1025
1026     if (GIMME == G_ARRAY) {
1027         dPOPPOPssrl;
1028         register I32 i, j;
1029         register SV *sv;
1030         I32 max;
1031
1032         if (SvGMAGICAL(left))
1033             mg_get(left);
1034         if (SvGMAGICAL(right))
1035             mg_get(right);
1036
1037         /* This code tries to decide if "$left .. $right" should use the
1038            magical string increment, or if the range is numeric (we make
1039            an exception for .."0" [#18165]). AMS 20021031. */
1040
1041         if (SvNIOKp(left) || !SvPOKp(left) ||
1042             SvNIOKp(right) || !SvPOKp(right) ||
1043             (looks_like_number(left) && *SvPVX(left) != '0' &&
1044              looks_like_number(right)))
1045         {
1046             if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1047                 DIE(aTHX_ "Range iterator outside integer range");
1048             i = SvIV(left);
1049             max = SvIV(right);
1050             if (max >= i) {
1051                 j = max - i + 1;
1052                 EXTEND_MORTAL(j);
1053                 EXTEND(SP, j);
1054             }
1055             else
1056                 j = 0;
1057             while (j--) {
1058                 sv = sv_2mortal(newSViv(i++));
1059                 PUSHs(sv);
1060             }
1061         }
1062         else {
1063             SV *final = sv_mortalcopy(right);
1064             STRLEN len, n_a;
1065             char *tmps = SvPV(final, len);
1066
1067             sv = sv_mortalcopy(left);
1068             SvPV_force(sv,n_a);
1069             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1070                 XPUSHs(sv);
1071                 if (strEQ(SvPVX(sv),tmps))
1072                     break;
1073                 sv = sv_2mortal(newSVsv(sv));
1074                 sv_inc(sv);
1075             }
1076         }
1077     }
1078     else {
1079         dTOPss;
1080         SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1081         int flop = 0;
1082         sv_inc(targ);
1083
1084         if (PL_op->op_private & OPpFLIP_LINENUM) {
1085             if (GvIO(PL_last_in_gv)) {
1086                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1087             }
1088             else {
1089                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1090                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1091             }
1092         }
1093         else {
1094             flop = SvTRUE(sv);
1095         }
1096
1097         if (flop) {
1098             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1099             sv_catpv(targ, "E0");
1100         }
1101         SETs(targ);
1102     }
1103
1104     RETURN;
1105 }
1106
1107 /* Control. */
1108
1109 static char *context_name[] = {
1110     "pseudo-block",
1111     "subroutine",
1112     "eval",
1113     "loop",
1114     "substitution",
1115     "block",
1116     "format"
1117 };
1118
1119 STATIC I32
1120 S_dopoptolabel(pTHX_ char *label)
1121 {
1122     register I32 i;
1123     register PERL_CONTEXT *cx;
1124
1125     for (i = cxstack_ix; i >= 0; i--) {
1126         cx = &cxstack[i];
1127         switch (CxTYPE(cx)) {
1128         case CXt_SUBST:
1129         case CXt_SUB:
1130         case CXt_FORMAT:
1131         case CXt_EVAL:
1132         case CXt_NULL:
1133             if (ckWARN(WARN_EXITING))
1134                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1135                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1136             if (CxTYPE(cx) == CXt_NULL)
1137                 return -1;
1138             break;
1139         case CXt_LOOP:
1140             if (!cx->blk_loop.label ||
1141               strNE(label, cx->blk_loop.label) ) {
1142                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1143                         (long)i, cx->blk_loop.label));
1144                 continue;
1145             }
1146             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1147             return i;
1148         }
1149     }
1150     return i;
1151 }
1152
1153 I32
1154 Perl_dowantarray(pTHX)
1155 {
1156     I32 gimme = block_gimme();
1157     return (gimme == G_VOID) ? G_SCALAR : gimme;
1158 }
1159
1160 I32
1161 Perl_block_gimme(pTHX)
1162 {
1163     I32 cxix;
1164
1165     cxix = dopoptosub(cxstack_ix);
1166     if (cxix < 0)
1167         return G_VOID;
1168
1169     switch (cxstack[cxix].blk_gimme) {
1170     case G_VOID:
1171         return G_VOID;
1172     case G_SCALAR:
1173         return G_SCALAR;
1174     case G_ARRAY:
1175         return G_ARRAY;
1176     default:
1177         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1178         /* NOTREACHED */
1179         return 0;
1180     }
1181 }
1182
1183 I32
1184 Perl_is_lvalue_sub(pTHX)
1185 {
1186     I32 cxix;
1187
1188     cxix = dopoptosub(cxstack_ix);
1189     assert(cxix >= 0);  /* We should only be called from inside subs */
1190
1191     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1192         return cxstack[cxix].blk_sub.lval;
1193     else
1194         return 0;
1195 }
1196
1197 STATIC I32
1198 S_dopoptosub(pTHX_ I32 startingblock)
1199 {
1200     return dopoptosub_at(cxstack, startingblock);
1201 }
1202
1203 STATIC I32
1204 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1205 {
1206     I32 i;
1207     register PERL_CONTEXT *cx;
1208     for (i = startingblock; i >= 0; i--) {
1209         cx = &cxstk[i];
1210         switch (CxTYPE(cx)) {
1211         default:
1212             continue;
1213         case CXt_EVAL:
1214         case CXt_SUB:
1215         case CXt_FORMAT:
1216             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1217             return i;
1218         }
1219     }
1220     return i;
1221 }
1222
1223 STATIC I32
1224 S_dopoptoeval(pTHX_ I32 startingblock)
1225 {
1226     I32 i;
1227     register PERL_CONTEXT *cx;
1228     for (i = startingblock; i >= 0; i--) {
1229         cx = &cxstack[i];
1230         switch (CxTYPE(cx)) {
1231         default:
1232             continue;
1233         case CXt_EVAL:
1234             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1235             return i;
1236         }
1237     }
1238     return i;
1239 }
1240
1241 STATIC I32
1242 S_dopoptoloop(pTHX_ I32 startingblock)
1243 {
1244     I32 i;
1245     register PERL_CONTEXT *cx;
1246     for (i = startingblock; i >= 0; i--) {
1247         cx = &cxstack[i];
1248         switch (CxTYPE(cx)) {
1249         case CXt_SUBST:
1250         case CXt_SUB:
1251         case CXt_FORMAT:
1252         case CXt_EVAL:
1253         case CXt_NULL:
1254             if (ckWARN(WARN_EXITING))
1255                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1256                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1257             if ((CxTYPE(cx)) == CXt_NULL)
1258                 return -1;
1259             break;
1260         case CXt_LOOP:
1261             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1262             return i;
1263         }
1264     }
1265     return i;
1266 }
1267
1268 void
1269 Perl_dounwind(pTHX_ I32 cxix)
1270 {
1271     register PERL_CONTEXT *cx;
1272     I32 optype;
1273
1274     while (cxstack_ix > cxix) {
1275         SV *sv;
1276         cx = &cxstack[cxstack_ix];
1277         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1278                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1279         /* Note: we don't need to restore the base context info till the end. */
1280         switch (CxTYPE(cx)) {
1281         case CXt_SUBST:
1282             POPSUBST(cx);
1283             continue;  /* not break */
1284         case CXt_SUB:
1285             POPSUB(cx,sv);
1286             LEAVESUB(sv);
1287             break;
1288         case CXt_EVAL:
1289             POPEVAL(cx);
1290             break;
1291         case CXt_LOOP:
1292             POPLOOP(cx);
1293             break;
1294         case CXt_NULL:
1295             break;
1296         case CXt_FORMAT:
1297             POPFORMAT(cx);
1298             break;
1299         }
1300         cxstack_ix--;
1301     }
1302 }
1303
1304 void
1305 Perl_qerror(pTHX_ SV *err)
1306 {
1307     if (PL_in_eval)
1308         sv_catsv(ERRSV, err);
1309     else if (PL_errors)
1310         sv_catsv(PL_errors, err);
1311     else
1312         Perl_warn(aTHX_ "%"SVf, err);
1313     ++PL_error_count;
1314 }
1315
1316 OP *
1317 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1318 {
1319     STRLEN n_a;
1320     IO *io;
1321     MAGIC *mg;
1322
1323     if (PL_in_eval) {
1324         I32 cxix;
1325         register PERL_CONTEXT *cx;
1326         I32 gimme;
1327         SV **newsp;
1328
1329         if (message) {
1330             if (PL_in_eval & EVAL_KEEPERR) {
1331                 static char prefix[] = "\t(in cleanup) ";
1332                 SV *err = ERRSV;
1333                 char *e = Nullch;
1334                 if (!SvPOK(err))
1335                     sv_setpv(err,"");
1336                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1337                     e = SvPV(err, n_a);
1338                     e += n_a - msglen;
1339                     if (*e != *message || strNE(e,message))
1340                         e = Nullch;
1341                 }
1342                 if (!e) {
1343                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1344                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1345                     sv_catpvn(err, message, msglen);
1346                     if (ckWARN(WARN_MISC)) {
1347                         STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1348                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1349                     }
1350                 }
1351             }
1352             else {
1353                 sv_setpvn(ERRSV, message, msglen);
1354             }
1355         }
1356         else
1357             message = SvPVx(ERRSV, msglen);
1358
1359         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1360                && PL_curstackinfo->si_prev)
1361         {
1362             dounwind(-1);
1363             POPSTACK;
1364         }
1365
1366         if (cxix >= 0) {
1367             I32 optype;
1368
1369             if (cxix < cxstack_ix)
1370                 dounwind(cxix);
1371
1372             POPBLOCK(cx,PL_curpm);
1373             if (CxTYPE(cx) != CXt_EVAL) {
1374                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1375                 PerlIO_write(Perl_error_log, message, msglen);
1376                 my_exit(1);
1377             }
1378             POPEVAL(cx);
1379
1380             if (gimme == G_SCALAR)
1381                 *++newsp = &PL_sv_undef;
1382             PL_stack_sp = newsp;
1383
1384             LEAVE;
1385
1386             /* LEAVE could clobber PL_curcop (see save_re_context())
1387              * XXX it might be better to find a way to avoid messing with
1388              * PL_curcop in save_re_context() instead, but this is a more
1389              * minimal fix --GSAR */
1390             PL_curcop = cx->blk_oldcop;
1391
1392             if (optype == OP_REQUIRE) {
1393                 char* msg = SvPVx(ERRSV, n_a);
1394                 DIE(aTHX_ "%sCompilation failed in require",
1395                     *msg ? msg : "Unknown error\n");
1396             }
1397             return pop_return();
1398         }
1399     }
1400     if (!message)
1401         message = SvPVx(ERRSV, msglen);
1402
1403     /* if STDERR is tied, print to it instead */
1404     if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1405         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1406         dSP; ENTER;
1407         PUSHMARK(SP);
1408         XPUSHs(SvTIED_obj((SV*)io, mg));
1409         XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1410         PUTBACK;
1411         call_method("PRINT", G_SCALAR);
1412         LEAVE;
1413     }
1414     else {
1415 #ifdef USE_SFIO
1416         /* SFIO can really mess with your errno */
1417         int e = errno;
1418 #endif
1419         PerlIO *serr = Perl_error_log;
1420
1421         PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1422         (void)PerlIO_flush(serr);
1423 #ifdef USE_SFIO
1424         errno = e;
1425 #endif
1426     }
1427     my_failure_exit();
1428     /* NOTREACHED */
1429     return 0;
1430 }
1431
1432 PP(pp_xor)
1433 {
1434     dSP; dPOPTOPssrl;
1435     if (SvTRUE(left) != SvTRUE(right))
1436         RETSETYES;
1437     else
1438         RETSETNO;
1439 }
1440
1441 PP(pp_andassign)
1442 {
1443     dSP;
1444     if (!SvTRUE(TOPs))
1445         RETURN;
1446     else
1447         RETURNOP(cLOGOP->op_other);
1448 }
1449
1450 PP(pp_orassign)
1451 {
1452     dSP;
1453     if (SvTRUE(TOPs))
1454         RETURN;
1455     else
1456         RETURNOP(cLOGOP->op_other);
1457 }
1458
1459 PP(pp_dorassign)
1460 {
1461     dSP;
1462     register SV* sv;
1463
1464     sv = TOPs;
1465     if (!sv || !SvANY(sv)) {
1466         RETURNOP(cLOGOP->op_other);
1467     }
1468
1469     switch (SvTYPE(sv)) {
1470     case SVt_PVAV:
1471         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1472             RETURN;
1473         break;
1474     case SVt_PVHV:
1475         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1476             RETURN;
1477         break;
1478     case SVt_PVCV:
1479         if (CvROOT(sv) || CvXSUB(sv))
1480             RETURN;
1481         break;
1482     default:
1483         if (SvGMAGICAL(sv))
1484             mg_get(sv);
1485         if (SvOK(sv))
1486             RETURN;
1487     }
1488
1489     RETURNOP(cLOGOP->op_other);
1490 }
1491
1492 PP(pp_caller)
1493 {
1494     dSP;
1495     register I32 cxix = dopoptosub(cxstack_ix);
1496     register PERL_CONTEXT *cx;
1497     register PERL_CONTEXT *ccstack = cxstack;
1498     PERL_SI *top_si = PL_curstackinfo;
1499     I32 dbcxix;
1500     I32 gimme;
1501     char *stashname;
1502     SV *sv;
1503     I32 count = 0;
1504
1505     if (MAXARG)
1506         count = POPi;
1507
1508     for (;;) {
1509         /* we may be in a higher stacklevel, so dig down deeper */
1510         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1511             top_si = top_si->si_prev;
1512             ccstack = top_si->si_cxstack;
1513             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1514         }
1515         if (cxix < 0) {
1516             if (GIMME != G_ARRAY) {
1517                 EXTEND(SP, 1);
1518                 RETPUSHUNDEF;
1519             }
1520             RETURN;
1521         }
1522         if (PL_DBsub && cxix >= 0 &&
1523                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1524             count++;
1525         if (!count--)
1526             break;
1527         cxix = dopoptosub_at(ccstack, cxix - 1);
1528     }
1529
1530     cx = &ccstack[cxix];
1531     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1532         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1533         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1534            field below is defined for any cx. */
1535         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1536             cx = &ccstack[dbcxix];
1537     }
1538
1539     stashname = CopSTASHPV(cx->blk_oldcop);
1540     if (GIMME != G_ARRAY) {
1541         EXTEND(SP, 1);
1542         if (!stashname)
1543             PUSHs(&PL_sv_undef);
1544         else {
1545             dTARGET;
1546             sv_setpv(TARG, stashname);
1547             PUSHs(TARG);
1548         }
1549         RETURN;
1550     }
1551
1552     EXTEND(SP, 10);
1553
1554     if (!stashname)
1555         PUSHs(&PL_sv_undef);
1556     else
1557         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1558     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1559     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1560     if (!MAXARG)
1561         RETURN;
1562     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1563         GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1564         /* So is ccstack[dbcxix]. */
1565         if (isGV(cvgv)) {
1566             sv = NEWSV(49, 0);
1567             gv_efullname3(sv, cvgv, Nullch);
1568             PUSHs(sv_2mortal(sv));
1569             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1570         }
1571         else {
1572             PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1573             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1574         }
1575     }
1576     else {
1577         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1578         PUSHs(sv_2mortal(newSViv(0)));
1579     }
1580     gimme = (I32)cx->blk_gimme;
1581     if (gimme == G_VOID)
1582         PUSHs(&PL_sv_undef);
1583     else
1584         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1585     if (CxTYPE(cx) == CXt_EVAL) {
1586         /* eval STRING */
1587         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1588             PUSHs(cx->blk_eval.cur_text);
1589             PUSHs(&PL_sv_no);
1590         }
1591         /* require */
1592         else if (cx->blk_eval.old_namesv) {
1593             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1594             PUSHs(&PL_sv_yes);
1595         }
1596         /* eval BLOCK (try blocks have old_namesv == 0) */
1597         else {
1598             PUSHs(&PL_sv_undef);
1599             PUSHs(&PL_sv_undef);
1600         }
1601     }
1602     else {
1603         PUSHs(&PL_sv_undef);
1604         PUSHs(&PL_sv_undef);
1605     }
1606     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1607         && CopSTASH_eq(PL_curcop, PL_debstash))
1608     {
1609         AV *ary = cx->blk_sub.argarray;
1610         int off = AvARRAY(ary) - AvALLOC(ary);
1611
1612         if (!PL_dbargs) {
1613             GV* tmpgv;
1614             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1615                                 SVt_PVAV)));
1616             GvMULTI_on(tmpgv);
1617             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1618         }
1619
1620         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1621             av_extend(PL_dbargs, AvFILLp(ary) + off);
1622         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1623         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1624     }
1625     /* XXX only hints propagated via op_private are currently
1626      * visible (others are not easily accessible, since they
1627      * use the global PL_hints) */
1628     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1629                              HINT_PRIVATE_MASK)));
1630     {
1631         SV * mask ;
1632         SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1633
1634         if  (old_warnings == pWARN_NONE ||
1635                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1636             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1637         else if (old_warnings == pWARN_ALL ||
1638                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1639             mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1640         else
1641             mask = newSVsv(old_warnings);
1642         PUSHs(sv_2mortal(mask));
1643     }
1644     RETURN;
1645 }
1646
1647 PP(pp_reset)
1648 {
1649     dSP;
1650     char *tmps;
1651     STRLEN n_a;
1652
1653     if (MAXARG < 1)
1654         tmps = "";
1655     else
1656         tmps = POPpx;
1657     sv_reset(tmps, CopSTASH(PL_curcop));
1658     PUSHs(&PL_sv_yes);
1659     RETURN;
1660 }
1661
1662 PP(pp_lineseq)
1663 {
1664     return NORMAL;
1665 }
1666
1667 /* like pp_nextstate, but used instead when the debugger is active */
1668
1669 PP(pp_dbstate)
1670 {
1671     PL_curcop = (COP*)PL_op;
1672     TAINT_NOT;          /* Each statement is presumed innocent */
1673     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1674     FREETMPS;
1675
1676     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1677             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1678     {
1679         dSP;
1680         register CV *cv;
1681         register PERL_CONTEXT *cx;
1682         I32 gimme = G_ARRAY;
1683         U8 hasargs;
1684         GV *gv;
1685
1686         gv = PL_DBgv;
1687         cv = GvCV(gv);
1688         if (!cv)
1689             DIE(aTHX_ "No DB::DB routine defined");
1690
1691         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1692             /* don't do recursive DB::DB call */
1693             return NORMAL;
1694
1695         ENTER;
1696         SAVETMPS;
1697
1698         SAVEI32(PL_debug);
1699         SAVESTACK_POS();
1700         PL_debug = 0;
1701         hasargs = 0;
1702         SPAGAIN;
1703
1704         push_return(PL_op->op_next);
1705         PUSHBLOCK(cx, CXt_SUB, SP);
1706         PUSHSUB_DB(cx);
1707         CvDEPTH(cv)++;
1708         (void)SvREFCNT_inc(cv);
1709         PAD_SET_CUR(CvPADLIST(cv),1);
1710         RETURNOP(CvSTART(cv));
1711     }
1712     else
1713         return NORMAL;
1714 }
1715
1716 PP(pp_scope)
1717 {
1718     return NORMAL;
1719 }
1720
1721 PP(pp_enteriter)
1722 {
1723     dSP; dMARK;
1724     register PERL_CONTEXT *cx;
1725     I32 gimme = GIMME_V;
1726     SV **svp;
1727     U32 cxtype = CXt_LOOP;
1728 #ifdef USE_ITHREADS
1729     void *iterdata;
1730 #endif
1731
1732     ENTER;
1733     SAVETMPS;
1734
1735     if (PL_op->op_targ) {
1736 #ifndef USE_ITHREADS
1737         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1738         SAVESPTR(*svp);
1739 #else
1740         SAVEPADSV(PL_op->op_targ);
1741         iterdata = INT2PTR(void*, PL_op->op_targ);
1742         cxtype |= CXp_PADVAR;
1743 #endif
1744     }
1745     else {
1746         GV *gv = (GV*)POPs;
1747         svp = &GvSV(gv);                        /* symbol table variable */
1748         SAVEGENERICSV(*svp);
1749         *svp = NEWSV(0,0);
1750 #ifdef USE_ITHREADS
1751         iterdata = (void*)gv;
1752 #endif
1753     }
1754
1755     ENTER;
1756
1757     PUSHBLOCK(cx, cxtype, SP);
1758 #ifdef USE_ITHREADS
1759     PUSHLOOP(cx, iterdata, MARK);
1760 #else
1761     PUSHLOOP(cx, svp, MARK);
1762 #endif
1763     if (PL_op->op_flags & OPf_STACKED) {
1764         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1765         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1766             dPOPss;
1767             /* See comment in pp_flop() */
1768             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1769                 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1770                 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1771                  looks_like_number((SV*)cx->blk_loop.iterary)))
1772             {
1773                  if (SvNV(sv) < IV_MIN ||
1774                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1775                      DIE(aTHX_ "Range iterator outside integer range");
1776                  cx->blk_loop.iterix = SvIV(sv);
1777                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1778             }
1779             else
1780                 cx->blk_loop.iterlval = newSVsv(sv);
1781         }
1782     }
1783     else {
1784         cx->blk_loop.iterary = PL_curstack;
1785         AvFILLp(PL_curstack) = SP - PL_stack_base;
1786         cx->blk_loop.iterix = MARK - PL_stack_base;
1787     }
1788
1789     RETURN;
1790 }
1791
1792 PP(pp_enterloop)
1793 {
1794     dSP;
1795     register PERL_CONTEXT *cx;
1796     I32 gimme = GIMME_V;
1797
1798     ENTER;
1799     SAVETMPS;
1800     ENTER;
1801
1802     PUSHBLOCK(cx, CXt_LOOP, SP);
1803     PUSHLOOP(cx, 0, SP);
1804
1805     RETURN;
1806 }
1807
1808 PP(pp_leaveloop)
1809 {
1810     dSP;
1811     register PERL_CONTEXT *cx;
1812     I32 gimme;
1813     SV **newsp;
1814     PMOP *newpm;
1815     SV **mark;
1816
1817     POPBLOCK(cx,newpm);
1818     mark = newsp;
1819     newsp = PL_stack_base + cx->blk_loop.resetsp;
1820
1821     TAINT_NOT;
1822     if (gimme == G_VOID)
1823         ; /* do nothing */
1824     else if (gimme == G_SCALAR) {
1825         if (mark < SP)
1826             *++newsp = sv_mortalcopy(*SP);
1827         else
1828             *++newsp = &PL_sv_undef;
1829     }
1830     else {
1831         while (mark < SP) {
1832             *++newsp = sv_mortalcopy(*++mark);
1833             TAINT_NOT;          /* Each item is independent */
1834         }
1835     }
1836     SP = newsp;
1837     PUTBACK;
1838
1839     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1840     PL_curpm = newpm;   /* ... and pop $1 et al */
1841
1842     LEAVE;
1843     LEAVE;
1844
1845     return NORMAL;
1846 }
1847
1848 PP(pp_return)
1849 {
1850     dSP; dMARK;
1851     I32 cxix;
1852     register PERL_CONTEXT *cx;
1853     bool popsub2 = FALSE;
1854     bool clear_errsv = FALSE;
1855     I32 gimme;
1856     SV **newsp;
1857     PMOP *newpm;
1858     I32 optype = 0;
1859     SV *sv;
1860
1861     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1862         if (cxstack_ix == PL_sortcxix
1863             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1864         {
1865             if (cxstack_ix > PL_sortcxix)
1866                 dounwind(PL_sortcxix);
1867             AvARRAY(PL_curstack)[1] = *SP;
1868             PL_stack_sp = PL_stack_base + 1;
1869             return 0;
1870         }
1871     }
1872
1873     cxix = dopoptosub(cxstack_ix);
1874     if (cxix < 0)
1875         DIE(aTHX_ "Can't return outside a subroutine");
1876     if (cxix < cxstack_ix)
1877         dounwind(cxix);
1878
1879     POPBLOCK(cx,newpm);
1880     switch (CxTYPE(cx)) {
1881     case CXt_SUB:
1882         popsub2 = TRUE;
1883         break;
1884     case CXt_EVAL:
1885         if (!(PL_in_eval & EVAL_KEEPERR))
1886             clear_errsv = TRUE;
1887         POPEVAL(cx);
1888         if (CxTRYBLOCK(cx))
1889             break;
1890         lex_end();
1891         if (optype == OP_REQUIRE &&
1892             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1893         {
1894             /* Unassume the success we assumed earlier. */
1895             SV *nsv = cx->blk_eval.old_namesv;
1896             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1897             DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1898         }
1899         break;
1900     case CXt_FORMAT:
1901         POPFORMAT(cx);
1902         break;
1903     default:
1904         DIE(aTHX_ "panic: return");
1905     }
1906
1907     TAINT_NOT;
1908     if (gimme == G_SCALAR) {
1909         if (MARK < SP) {
1910             if (popsub2) {
1911                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1912                     if (SvTEMP(TOPs)) {
1913                         *++newsp = SvREFCNT_inc(*SP);
1914                         FREETMPS;
1915                         sv_2mortal(*newsp);
1916                     }
1917                     else {
1918                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1919                         FREETMPS;
1920                         *++newsp = sv_mortalcopy(sv);
1921                         SvREFCNT_dec(sv);
1922                     }
1923                 }
1924                 else
1925                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1926             }
1927             else
1928                 *++newsp = sv_mortalcopy(*SP);
1929         }
1930         else
1931             *++newsp = &PL_sv_undef;
1932     }
1933     else if (gimme == G_ARRAY) {
1934         while (++MARK <= SP) {
1935             *++newsp = (popsub2 && SvTEMP(*MARK))
1936                         ? *MARK : sv_mortalcopy(*MARK);
1937             TAINT_NOT;          /* Each item is independent */
1938         }
1939     }
1940     PL_stack_sp = newsp;
1941
1942     /* Stack values are safe: */
1943     if (popsub2) {
1944         POPSUB(cx,sv);  /* release CV and @_ ... */
1945     }
1946     else
1947         sv = Nullsv;
1948     PL_curpm = newpm;   /* ... and pop $1 et al */
1949
1950     LEAVE;
1951     LEAVESUB(sv);
1952     if (clear_errsv)
1953         sv_setpv(ERRSV,"");
1954     return pop_return();
1955 }
1956
1957 PP(pp_last)
1958 {
1959     dSP;
1960     I32 cxix;
1961     register PERL_CONTEXT *cx;
1962     I32 pop2 = 0;
1963     I32 gimme;
1964     I32 optype;
1965     OP *nextop;
1966     SV **newsp;
1967     PMOP *newpm;
1968     SV **mark;
1969     SV *sv = Nullsv;
1970
1971     if (PL_op->op_flags & OPf_SPECIAL) {
1972         cxix = dopoptoloop(cxstack_ix);
1973         if (cxix < 0)
1974             DIE(aTHX_ "Can't \"last\" outside a loop block");
1975     }
1976     else {
1977         cxix = dopoptolabel(cPVOP->op_pv);
1978         if (cxix < 0)
1979             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1980     }
1981     if (cxix < cxstack_ix)
1982         dounwind(cxix);
1983
1984     POPBLOCK(cx,newpm);
1985     mark = newsp;
1986     switch (CxTYPE(cx)) {
1987     case CXt_LOOP:
1988         pop2 = CXt_LOOP;
1989         newsp = PL_stack_base + cx->blk_loop.resetsp;
1990         nextop = cx->blk_loop.last_op->op_next;
1991         break;
1992     case CXt_SUB:
1993         pop2 = CXt_SUB;
1994         nextop = pop_return();
1995         break;
1996     case CXt_EVAL:
1997         POPEVAL(cx);
1998         nextop = pop_return();
1999         break;
2000     case CXt_FORMAT:
2001         POPFORMAT(cx);
2002         nextop = pop_return();
2003         break;
2004     default:
2005         DIE(aTHX_ "panic: last");
2006     }
2007
2008     TAINT_NOT;
2009     if (gimme == G_SCALAR) {
2010         if (MARK < SP)
2011             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2012                         ? *SP : sv_mortalcopy(*SP);
2013         else
2014             *++newsp = &PL_sv_undef;
2015     }
2016     else if (gimme == G_ARRAY) {
2017         while (++MARK <= SP) {
2018             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2019                         ? *MARK : sv_mortalcopy(*MARK);
2020             TAINT_NOT;          /* Each item is independent */
2021         }
2022     }
2023     SP = newsp;
2024     PUTBACK;
2025
2026     /* Stack values are safe: */
2027     switch (pop2) {
2028     case CXt_LOOP:
2029         POPLOOP(cx);    /* release loop vars ... */
2030         LEAVE;
2031         break;
2032     case CXt_SUB:
2033         POPSUB(cx,sv);  /* release CV and @_ ... */
2034         break;
2035     }
2036     PL_curpm = newpm;   /* ... and pop $1 et al */
2037
2038     LEAVE;
2039     LEAVESUB(sv);
2040     return nextop;
2041 }
2042
2043 PP(pp_next)
2044 {
2045     I32 cxix;
2046     register PERL_CONTEXT *cx;
2047     I32 inner;
2048
2049     if (PL_op->op_flags & OPf_SPECIAL) {
2050         cxix = dopoptoloop(cxstack_ix);
2051         if (cxix < 0)
2052             DIE(aTHX_ "Can't \"next\" outside a loop block");
2053     }
2054     else {
2055         cxix = dopoptolabel(cPVOP->op_pv);
2056         if (cxix < 0)
2057             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2058     }
2059     if (cxix < cxstack_ix)
2060         dounwind(cxix);
2061
2062     /* clear off anything above the scope we're re-entering, but
2063      * save the rest until after a possible continue block */
2064     inner = PL_scopestack_ix;
2065     TOPBLOCK(cx);
2066     if (PL_scopestack_ix < inner)
2067         leave_scope(PL_scopestack[PL_scopestack_ix]);
2068     return cx->blk_loop.next_op;
2069 }
2070
2071 PP(pp_redo)
2072 {
2073     I32 cxix;
2074     register PERL_CONTEXT *cx;
2075     I32 oldsave;
2076
2077     if (PL_op->op_flags & OPf_SPECIAL) {
2078         cxix = dopoptoloop(cxstack_ix);
2079         if (cxix < 0)
2080             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2081     }
2082     else {
2083         cxix = dopoptolabel(cPVOP->op_pv);
2084         if (cxix < 0)
2085             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2086     }
2087     if (cxix < cxstack_ix)
2088         dounwind(cxix);
2089
2090     TOPBLOCK(cx);
2091     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2092     LEAVE_SCOPE(oldsave);
2093     return cx->blk_loop.redo_op;
2094 }
2095
2096 STATIC OP *
2097 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2098 {
2099     OP *kid = Nullop;
2100     OP **ops = opstack;
2101     static char too_deep[] = "Target of goto is too deeply nested";
2102
2103     if (ops >= oplimit)
2104         Perl_croak(aTHX_ too_deep);
2105     if (o->op_type == OP_LEAVE ||
2106         o->op_type == OP_SCOPE ||
2107         o->op_type == OP_LEAVELOOP ||
2108         o->op_type == OP_LEAVESUB ||
2109         o->op_type == OP_LEAVETRY)
2110     {
2111         *ops++ = cUNOPo->op_first;
2112         if (ops >= oplimit)
2113             Perl_croak(aTHX_ too_deep);
2114     }
2115     *ops = 0;
2116     if (o->op_flags & OPf_KIDS) {
2117         /* First try all the kids at this level, since that's likeliest. */
2118         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2119             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2120                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2121                 return kid;
2122         }
2123         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2124             if (kid == PL_lastgotoprobe)
2125                 continue;
2126             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2127                 if (ops == opstack)
2128                     *ops++ = kid;
2129                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2130                          ops[-1]->op_type == OP_DBSTATE)
2131                     ops[-1] = kid;
2132                 else
2133                     *ops++ = kid;
2134             }
2135             if ((o = dofindlabel(kid, label, ops, oplimit)))
2136                 return o;
2137         }
2138     }
2139     *ops = 0;
2140     return 0;
2141 }
2142
2143 PP(pp_dump)
2144 {
2145     return pp_goto();
2146     /*NOTREACHED*/
2147 }
2148
2149 PP(pp_goto)
2150 {
2151     dSP;
2152     OP *retop = 0;
2153     I32 ix;
2154     register PERL_CONTEXT *cx;
2155 #define GOTO_DEPTH 64
2156     OP *enterops[GOTO_DEPTH];
2157     char *label;
2158     int do_dump = (PL_op->op_type == OP_DUMP);
2159     static char must_have_label[] = "goto must have label";
2160
2161     label = 0;
2162     if (PL_op->op_flags & OPf_STACKED) {
2163         SV *sv = POPs;
2164         STRLEN n_a;
2165
2166         /* This egregious kludge implements goto &subroutine */
2167         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2168             I32 cxix;
2169             register PERL_CONTEXT *cx;
2170             CV* cv = (CV*)SvRV(sv);
2171             SV** mark;
2172             I32 items = 0;
2173             I32 oldsave;
2174
2175         retry:
2176             if (!CvROOT(cv) && !CvXSUB(cv)) {
2177                 GV *gv = CvGV(cv);
2178                 GV *autogv;
2179                 if (gv) {
2180                     SV *tmpstr;
2181                     /* autoloaded stub? */
2182                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2183                         goto retry;
2184                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2185                                           GvNAMELEN(gv), FALSE);
2186                     if (autogv && (cv = GvCV(autogv)))
2187                         goto retry;
2188                     tmpstr = sv_newmortal();
2189                     gv_efullname3(tmpstr, gv, Nullch);
2190                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2191                 }
2192                 DIE(aTHX_ "Goto undefined subroutine");
2193             }
2194
2195             /* First do some returnish stuff. */
2196             FREETMPS;
2197             cxix = dopoptosub(cxstack_ix);
2198             if (cxix < 0)
2199                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2200             if (cxix < cxstack_ix)
2201                 dounwind(cxix);
2202             TOPBLOCK(cx);
2203             if (CxREALEVAL(cx))
2204                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2205             mark = PL_stack_sp;
2206             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2207                 /* put @_ back onto stack */
2208                 AV* av = cx->blk_sub.argarray;
2209
2210                 items = AvFILLp(av) + 1;
2211                 PL_stack_sp++;
2212                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2213                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2214                 PL_stack_sp += items;
2215                 SvREFCNT_dec(GvAV(PL_defgv));
2216                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2217                 /* abandon @_ if it got reified */
2218                 if (AvREAL(av)) {
2219                     (void)sv_2mortal((SV*)av);  /* delay until return */
2220                     av = newAV();
2221                     av_extend(av, items-1);
2222                     AvFLAGS(av) = AVf_REIFY;
2223                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2224                 }
2225             }
2226             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2227                 AV* av;
2228                 av = GvAV(PL_defgv);
2229                 items = AvFILLp(av) + 1;
2230                 PL_stack_sp++;
2231                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2232                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2233                 PL_stack_sp += items;
2234             }
2235             if (CxTYPE(cx) == CXt_SUB &&
2236                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2237                 SvREFCNT_dec(cx->blk_sub.cv);
2238             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2239             LEAVE_SCOPE(oldsave);
2240
2241             /* Now do some callish stuff. */
2242             SAVETMPS;
2243             if (CvXSUB(cv)) {
2244 #ifdef PERL_XSUB_OLDSTYLE
2245                 if (CvOLDSTYLE(cv)) {
2246                     I32 (*fp3)(int,int,int);
2247                     while (SP > mark) {
2248                         SP[1] = SP[0];
2249                         SP--;
2250                     }
2251                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2252                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2253                                    mark - PL_stack_base + 1,
2254                                    items);
2255                     SP = PL_stack_base + items;
2256                 }
2257                 else
2258 #endif /* PERL_XSUB_OLDSTYLE */
2259                 {
2260                     SV **newsp;
2261                     I32 gimme;
2262
2263                     PL_stack_sp--;              /* There is no cv arg. */
2264                     /* Push a mark for the start of arglist */
2265                     PUSHMARK(mark);
2266                     (void)(*CvXSUB(cv))(aTHX_ cv);
2267                     /* Pop the current context like a decent sub should */
2268                     POPBLOCK(cx, PL_curpm);
2269                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2270                 }
2271                 LEAVE;
2272                 return pop_return();
2273             }
2274             else {
2275                 AV* padlist = CvPADLIST(cv);
2276                 if (CxTYPE(cx) == CXt_EVAL) {
2277                     PL_in_eval = cx->blk_eval.old_in_eval;
2278                     PL_eval_root = cx->blk_eval.old_eval_root;
2279                     cx->cx_type = CXt_SUB;
2280                     cx->blk_sub.hasargs = 0;
2281                 }
2282                 cx->blk_sub.cv = cv;
2283                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2284
2285                 CvDEPTH(cv)++;
2286                 if (CvDEPTH(cv) < 2)
2287                     (void)SvREFCNT_inc(cv);
2288                 else {
2289                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2290                         sub_crush_depth(cv);
2291                     pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2292                 }
2293                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2294                 if (cx->blk_sub.hasargs)
2295                 {
2296                     AV* av = (AV*)PAD_SVl(0);
2297                     SV** ary;
2298
2299                     cx->blk_sub.savearray = GvAV(PL_defgv);
2300                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2301                     CX_CURPAD_SAVE(cx->blk_sub);
2302                     cx->blk_sub.argarray = av;
2303                     ++mark;
2304
2305                     if (items >= AvMAX(av) + 1) {
2306                         ary = AvALLOC(av);
2307                         if (AvARRAY(av) != ary) {
2308                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2309                             SvPVX(av) = (char*)ary;
2310                         }
2311                         if (items >= AvMAX(av) + 1) {
2312                             AvMAX(av) = items - 1;
2313                             Renew(ary,items+1,SV*);
2314                             AvALLOC(av) = ary;
2315                             SvPVX(av) = (char*)ary;
2316                         }
2317                     }
2318                     Copy(mark,AvARRAY(av),items,SV*);
2319                     AvFILLp(av) = items - 1;
2320                     assert(!AvREAL(av));
2321                     while (items--) {
2322                         if (*mark)
2323                             SvTEMP_off(*mark);
2324                         mark++;
2325                     }
2326                 }
2327                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2328                     /*
2329                      * We do not care about using sv to call CV;
2330                      * it's for informational purposes only.
2331                      */
2332                     SV *sv = GvSV(PL_DBsub);
2333                     CV *gotocv;
2334
2335                     if (PERLDB_SUB_NN) {
2336                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2337                     } else {
2338                         save_item(sv);
2339                         gv_efullname3(sv, CvGV(cv), Nullch);
2340                     }
2341                     if (  PERLDB_GOTO
2342                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2343                         PUSHMARK( PL_stack_sp );
2344                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2345                         PL_stack_sp--;
2346                     }
2347                 }
2348                 RETURNOP(CvSTART(cv));
2349             }
2350         }
2351         else {
2352             label = SvPV(sv,n_a);
2353             if (!(do_dump || *label))
2354                 DIE(aTHX_ must_have_label);
2355         }
2356     }
2357     else if (PL_op->op_flags & OPf_SPECIAL) {
2358         if (! do_dump)
2359             DIE(aTHX_ must_have_label);
2360     }
2361     else
2362         label = cPVOP->op_pv;
2363
2364     if (label && *label) {
2365         OP *gotoprobe = 0;
2366         bool leaving_eval = FALSE;
2367         bool in_block = FALSE;
2368         PERL_CONTEXT *last_eval_cx = 0;
2369
2370         /* find label */
2371
2372         PL_lastgotoprobe = 0;
2373         *enterops = 0;
2374         for (ix = cxstack_ix; ix >= 0; ix--) {
2375             cx = &cxstack[ix];
2376             switch (CxTYPE(cx)) {
2377             case CXt_EVAL:
2378                 leaving_eval = TRUE;
2379                 if (CxREALEVAL(cx)) {
2380                     gotoprobe = (last_eval_cx ?
2381                                 last_eval_cx->blk_eval.old_eval_root :
2382                                 PL_eval_root);
2383                     last_eval_cx = cx;
2384                     break;
2385                 }
2386                 /* else fall through */
2387             case CXt_LOOP:
2388                 gotoprobe = cx->blk_oldcop->op_sibling;
2389                 break;
2390             case CXt_SUBST:
2391                 continue;
2392             case CXt_BLOCK:
2393                 if (ix) {
2394                     gotoprobe = cx->blk_oldcop->op_sibling;
2395                     in_block = TRUE;
2396                 } else
2397                     gotoprobe = PL_main_root;
2398                 break;
2399             case CXt_SUB:
2400                 if (CvDEPTH(cx->blk_sub.cv)) {
2401                     gotoprobe = CvROOT(cx->blk_sub.cv);
2402                     break;
2403                 }
2404                 /* FALL THROUGH */
2405             case CXt_FORMAT:
2406             case CXt_NULL:
2407                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2408             default:
2409                 if (ix)
2410                     DIE(aTHX_ "panic: goto");
2411                 gotoprobe = PL_main_root;
2412                 break;
2413             }
2414             if (gotoprobe) {
2415                 retop = dofindlabel(gotoprobe, label,
2416                                     enterops, enterops + GOTO_DEPTH);
2417                 if (retop)
2418                     break;
2419             }
2420             PL_lastgotoprobe = gotoprobe;
2421         }
2422         if (!retop)
2423             DIE(aTHX_ "Can't find label %s", label);
2424
2425         /* if we're leaving an eval, check before we pop any frames
2426            that we're not going to punt, otherwise the error
2427            won't be caught */
2428
2429         if (leaving_eval && *enterops && enterops[1]) {
2430             I32 i;
2431             for (i = 1; enterops[i]; i++)
2432                 if (enterops[i]->op_type == OP_ENTERITER)
2433                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2434         }
2435
2436         /* pop unwanted frames */
2437
2438         if (ix < cxstack_ix) {
2439             I32 oldsave;
2440
2441             if (ix < 0)
2442                 ix = 0;
2443             dounwind(ix);
2444             TOPBLOCK(cx);
2445             oldsave = PL_scopestack[PL_scopestack_ix];
2446             LEAVE_SCOPE(oldsave);
2447         }
2448
2449         /* push wanted frames */
2450
2451         if (*enterops && enterops[1]) {
2452             OP *oldop = PL_op;
2453             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2454             for (; enterops[ix]; ix++) {
2455                 PL_op = enterops[ix];
2456                 /* Eventually we may want to stack the needed arguments
2457                  * for each op.  For now, we punt on the hard ones. */
2458                 if (PL_op->op_type == OP_ENTERITER)
2459                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2460                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2461             }
2462             PL_op = oldop;
2463         }
2464     }
2465
2466     if (do_dump) {
2467 #ifdef VMS
2468         if (!retop) retop = PL_main_start;
2469 #endif
2470         PL_restartop = retop;
2471         PL_do_undump = TRUE;
2472
2473         my_unexec();
2474
2475         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2476         PL_do_undump = FALSE;
2477     }
2478
2479     RETURNOP(retop);
2480 }
2481
2482 PP(pp_exit)
2483 {
2484     dSP;
2485     I32 anum;
2486
2487     if (MAXARG < 1)
2488         anum = 0;
2489     else {
2490         anum = SvIVx(POPs);
2491 #ifdef VMS
2492         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2493             anum = 0;
2494         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2495 #endif
2496     }
2497     PL_exit_flags |= PERL_EXIT_EXPECTED;
2498     my_exit(anum);
2499     PUSHs(&PL_sv_undef);
2500     RETURN;
2501 }
2502
2503 #ifdef NOTYET
2504 PP(pp_nswitch)
2505 {
2506     dSP;
2507     NV value = SvNVx(GvSV(cCOP->cop_gv));
2508     register I32 match = I_32(value);
2509
2510     if (value < 0.0) {
2511         if (((NV)match) > value)
2512             --match;            /* was fractional--truncate other way */
2513     }
2514     match -= cCOP->uop.scop.scop_offset;
2515     if (match < 0)
2516         match = 0;
2517     else if (match > cCOP->uop.scop.scop_max)
2518         match = cCOP->uop.scop.scop_max;
2519     PL_op = cCOP->uop.scop.scop_next[match];
2520     RETURNOP(PL_op);
2521 }
2522
2523 PP(pp_cswitch)
2524 {
2525     dSP;
2526     register I32 match;
2527
2528     if (PL_multiline)
2529         PL_op = PL_op->op_next;                 /* can't assume anything */
2530     else {
2531         STRLEN n_a;
2532         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2533         match -= cCOP->uop.scop.scop_offset;
2534         if (match < 0)
2535             match = 0;
2536         else if (match > cCOP->uop.scop.scop_max)
2537             match = cCOP->uop.scop.scop_max;
2538         PL_op = cCOP->uop.scop.scop_next[match];
2539     }
2540     RETURNOP(PL_op);
2541 }
2542 #endif
2543
2544 /* Eval. */
2545
2546 STATIC void
2547 S_save_lines(pTHX_ AV *array, SV *sv)
2548 {
2549     register char *s = SvPVX(sv);
2550     register char *send = SvPVX(sv) + SvCUR(sv);
2551     register char *t;
2552     register I32 line = 1;
2553
2554     while (s && s < send) {
2555         SV *tmpstr = NEWSV(85,0);
2556
2557         sv_upgrade(tmpstr, SVt_PVMG);
2558         t = strchr(s, '\n');
2559         if (t)
2560             t++;
2561         else
2562             t = send;
2563
2564         sv_setpvn(tmpstr, s, t - s);
2565         av_store(array, line++, tmpstr);
2566         s = t;
2567     }
2568 }
2569
2570 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2571 STATIC void *
2572 S_docatch_body(pTHX_ va_list args)
2573 {
2574     return docatch_body();
2575 }
2576 #endif
2577
2578 STATIC void *
2579 S_docatch_body(pTHX)
2580 {
2581     CALLRUNOPS(aTHX);
2582     return NULL;
2583 }
2584
2585 STATIC OP *
2586 S_docatch(pTHX_ OP *o)
2587 {
2588     int ret;
2589     OP *oldop = PL_op;
2590     OP *retop;
2591     volatile PERL_SI *cursi = PL_curstackinfo;
2592     dJMPENV;
2593
2594 #ifdef DEBUGGING
2595     assert(CATCH_GET == TRUE);
2596 #endif
2597     PL_op = o;
2598
2599     /* Normally, the leavetry at the end of this block of ops will
2600      * pop an op off the return stack and continue there. By setting
2601      * the op to Nullop, we force an exit from the inner runops()
2602      * loop. DAPM.
2603      */
2604     retop = pop_return();
2605     push_return(Nullop);
2606
2607 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2608  redo_body:
2609     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2610 #else
2611     JMPENV_PUSH(ret);
2612 #endif
2613     switch (ret) {
2614     case 0:
2615 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2616  redo_body:
2617         docatch_body();
2618 #endif
2619         break;
2620     case 3:
2621         /* die caught by an inner eval - continue inner loop */
2622         if (PL_restartop && cursi == PL_curstackinfo) {
2623             PL_op = PL_restartop;
2624             PL_restartop = 0;
2625             goto redo_body;
2626         }
2627         /* a die in this eval - continue in outer loop */
2628         if (!PL_restartop)
2629             break;
2630         /* FALL THROUGH */
2631     default:
2632         JMPENV_POP;
2633         PL_op = oldop;
2634         JMPENV_JUMP(ret);
2635         /* NOTREACHED */
2636     }
2637     JMPENV_POP;
2638     PL_op = oldop;
2639     return retop;
2640 }
2641
2642 OP *
2643 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2644 /* sv Text to convert to OP tree. */
2645 /* startop op_free() this to undo. */
2646 /* code Short string id of the caller. */
2647 {
2648     dSP;                                /* Make POPBLOCK work. */
2649     PERL_CONTEXT *cx;
2650     SV **newsp;
2651     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2652     I32 optype;
2653     OP dummy;
2654     OP *rop;
2655     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2656     char *tmpbuf = tbuf;
2657     char *safestr;
2658     int runtime;
2659     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2660
2661     ENTER;
2662     lex_start(sv);
2663     SAVETMPS;
2664     /* switch to eval mode */
2665
2666     if (PL_curcop == &PL_compiling) {
2667         SAVECOPSTASH_FREE(&PL_compiling);
2668         CopSTASH_set(&PL_compiling, PL_curstash);
2669     }
2670     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2671         SV *sv = sv_newmortal();
2672         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2673                        code, (unsigned long)++PL_evalseq,
2674                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2675         tmpbuf = SvPVX(sv);
2676     }
2677     else
2678         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2679     SAVECOPFILE_FREE(&PL_compiling);
2680     CopFILE_set(&PL_compiling, tmpbuf+2);
2681     SAVECOPLINE(&PL_compiling);
2682     CopLINE_set(&PL_compiling, 1);
2683     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2684        deleting the eval's FILEGV from the stash before gv_check() runs
2685        (i.e. before run-time proper). To work around the coredump that
2686        ensues, we always turn GvMULTI_on for any globals that were
2687        introduced within evals. See force_ident(). GSAR 96-10-12 */
2688     safestr = savepv(tmpbuf);
2689     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2690     SAVEHINTS();
2691 #ifdef OP_IN_REGISTER
2692     PL_opsave = op;
2693 #else
2694     SAVEVPTR(PL_op);
2695 #endif
2696     PL_hints &= HINT_UTF8;
2697
2698     /* we get here either during compilation, or via pp_regcomp at runtime */
2699     runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2700     if (runtime)
2701         runcv = find_runcv(NULL);
2702
2703     PL_op = &dummy;
2704     PL_op->op_type = OP_ENTEREVAL;
2705     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2706     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2707     PUSHEVAL(cx, 0, Nullgv);
2708
2709     if (runtime)
2710         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2711     else
2712         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2713     POPBLOCK(cx,PL_curpm);
2714     POPEVAL(cx);
2715
2716     (*startop)->op_type = OP_NULL;
2717     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2718     lex_end();
2719     /* XXX DAPM do this properly one year */
2720     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2721     LEAVE;
2722     if (PL_curcop == &PL_compiling)
2723         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2724 #ifdef OP_IN_REGISTER
2725     op = PL_opsave;
2726 #endif
2727     return rop;
2728 }
2729
2730
2731 /*
2732 =for apidoc find_runcv
2733
2734 Locate the CV corresponding to the currently executing sub or eval.
2735 If db_seqp is non_null, skip CVs that are in the DB package and populate
2736 *db_seqp with the cop sequence number at the point that the DB:: code was
2737 entered. (allows debuggers to eval in the scope of the breakpoint rather
2738 than in in the scope of the debuger itself).
2739
2740 =cut
2741 */
2742
2743 CV*
2744 Perl_find_runcv(pTHX_ U32 *db_seqp)
2745 {
2746     I32          ix;
2747     PERL_SI      *si;
2748     PERL_CONTEXT *cx;
2749
2750     if (db_seqp)
2751         *db_seqp = PL_curcop->cop_seq;
2752     for (si = PL_curstackinfo; si; si = si->si_prev) {
2753         for (ix = si->si_cxix; ix >= 0; ix--) {
2754             cx = &(si->si_cxstack[ix]);
2755             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2756                 CV *cv = cx->blk_sub.cv;
2757                 /* skip DB:: code */
2758                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2759                     *db_seqp = cx->blk_oldcop->cop_seq;
2760                     continue;
2761                 }
2762                 return cv;
2763             }
2764             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2765                 return PL_compcv;
2766         }
2767     }
2768     return PL_main_cv;
2769 }
2770
2771
2772 /* Compile a require/do, an eval '', or a /(?{...})/.
2773  * In the last case, startop is non-null, and contains the address of
2774  * a pointer that should be set to the just-compiled code.
2775  * outside is the lexically enclosing CV (if any) that invoked us.
2776  */
2777
2778 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2779 STATIC OP *
2780 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2781 {
2782     dSP;
2783     OP *saveop = PL_op;
2784
2785     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2786                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2787                   : EVAL_INEVAL);
2788
2789     PUSHMARK(SP);
2790
2791     SAVESPTR(PL_compcv);
2792     PL_compcv = (CV*)NEWSV(1104,0);
2793     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2794     CvEVAL_on(PL_compcv);
2795     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2796     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2797
2798     CvOUTSIDE_SEQ(PL_compcv) = seq;
2799     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2800
2801     /* set up a scratch pad */
2802
2803     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2804
2805
2806     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2807
2808     /* make sure we compile in the right package */
2809
2810     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2811         SAVESPTR(PL_curstash);
2812         PL_curstash = CopSTASH(PL_curcop);
2813     }
2814     SAVESPTR(PL_beginav);
2815     PL_beginav = newAV();
2816     SAVEFREESV(PL_beginav);
2817     SAVEI32(PL_error_count);
2818
2819     /* try to compile it */
2820
2821     PL_eval_root = Nullop;
2822     PL_error_count = 0;
2823     PL_curcop = &PL_compiling;
2824     PL_curcop->cop_arybase = 0;
2825     if (saveop && saveop->op_flags & OPf_SPECIAL)
2826         PL_in_eval |= EVAL_KEEPERR;
2827     else
2828         sv_setpv(ERRSV,"");
2829     if (yyparse() || PL_error_count || !PL_eval_root) {
2830         SV **newsp;
2831         I32 gimme;
2832         PERL_CONTEXT *cx;
2833         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2834         STRLEN n_a;
2835
2836         PL_op = saveop;
2837         if (PL_eval_root) {
2838             op_free(PL_eval_root);
2839             PL_eval_root = Nullop;
2840         }
2841         SP = PL_stack_base + POPMARK;           /* pop original mark */
2842         if (!startop) {
2843             POPBLOCK(cx,PL_curpm);
2844             POPEVAL(cx);
2845             pop_return();
2846         }
2847         lex_end();
2848         LEAVE;
2849         if (optype == OP_REQUIRE) {
2850             char* msg = SvPVx(ERRSV, n_a);
2851             DIE(aTHX_ "%sCompilation failed in require",
2852                 *msg ? msg : "Unknown error\n");
2853         }
2854         else if (startop) {
2855             char* msg = SvPVx(ERRSV, n_a);
2856
2857             POPBLOCK(cx,PL_curpm);
2858             POPEVAL(cx);
2859             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2860                        (*msg ? msg : "Unknown error\n"));
2861         }
2862         else {
2863             char* msg = SvPVx(ERRSV, n_a);
2864             if (!*msg) {
2865                 sv_setpv(ERRSV, "Compilation error");
2866             }
2867         }
2868         RETPUSHUNDEF;
2869     }
2870     CopLINE_set(&PL_compiling, 0);
2871     if (startop) {
2872         *startop = PL_eval_root;
2873     } else
2874         SAVEFREEOP(PL_eval_root);
2875     if (gimme & G_VOID)
2876         scalarvoid(PL_eval_root);
2877     else if (gimme & G_ARRAY)
2878         list(PL_eval_root);
2879     else
2880         scalar(PL_eval_root);
2881
2882     DEBUG_x(dump_eval());
2883
2884     /* Register with debugger: */
2885     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2886         CV *cv = get_cv("DB::postponed", FALSE);
2887         if (cv) {
2888             dSP;
2889             PUSHMARK(SP);
2890             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2891             PUTBACK;
2892             call_sv((SV*)cv, G_DISCARD);
2893         }
2894     }
2895
2896     /* compiled okay, so do it */
2897
2898     CvDEPTH(PL_compcv) = 1;
2899     SP = PL_stack_base + POPMARK;               /* pop original mark */
2900     PL_op = saveop;                     /* The caller may need it. */
2901     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2902
2903     RETURNOP(PL_eval_start);
2904 }
2905
2906 STATIC PerlIO *
2907 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2908 {
2909     STRLEN namelen = strlen(name);
2910     PerlIO *fp;
2911
2912     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2913         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2914         char *pmc = SvPV_nolen(pmcsv);
2915         Stat_t pmstat;
2916         Stat_t pmcstat;
2917         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2918             fp = PerlIO_open(name, mode);
2919         }
2920         else {
2921             if (PerlLIO_stat(name, &pmstat) < 0 ||
2922                 pmstat.st_mtime < pmcstat.st_mtime)
2923             {
2924                 fp = PerlIO_open(pmc, mode);
2925             }
2926             else {
2927                 fp = PerlIO_open(name, mode);
2928             }
2929         }
2930         SvREFCNT_dec(pmcsv);
2931     }
2932     else {
2933         fp = PerlIO_open(name, mode);
2934     }
2935     return fp;
2936 }
2937
2938 PP(pp_require)
2939 {
2940     dSP;
2941     register PERL_CONTEXT *cx;
2942     SV *sv;
2943     char *name;
2944     STRLEN len;
2945     char *tryname = Nullch;
2946     SV *namesv = Nullsv;
2947     SV** svp;
2948     I32 gimme = GIMME_V;
2949     PerlIO *tryrsfp = 0;
2950     STRLEN n_a;
2951     int filter_has_file = 0;
2952     GV *filter_child_proc = 0;
2953     SV *filter_state = 0;
2954     SV *filter_sub = 0;
2955     SV *hook_sv = 0;
2956     SV *encoding;
2957     OP *op;
2958
2959     sv = POPs;
2960     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2961         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2962             UV rev = 0, ver = 0, sver = 0;
2963             STRLEN len;
2964             U8 *s = (U8*)SvPVX(sv);
2965             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2966             if (s < end) {
2967                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2968                 s += len;
2969                 if (s < end) {
2970                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
2971                     s += len;
2972                     if (s < end)
2973                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
2974                 }
2975             }
2976             if (PERL_REVISION < rev
2977                 || (PERL_REVISION == rev
2978                     && (PERL_VERSION < ver
2979                         || (PERL_VERSION == ver
2980                             && PERL_SUBVERSION < sver))))
2981             {
2982                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2983                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2984                     PERL_VERSION, PERL_SUBVERSION);
2985             }
2986             if (ckWARN(WARN_PORTABLE))
2987                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2988                         "v-string in use/require non-portable");
2989             RETPUSHYES;
2990         }
2991         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
2992             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2993                 + ((NV)PERL_SUBVERSION/(NV)1000000)
2994                 + 0.00000099 < SvNV(sv))
2995             {
2996                 NV nrev = SvNV(sv);
2997                 UV rev = (UV)nrev;
2998                 NV nver = (nrev - rev) * 1000;
2999                 UV ver = (UV)(nver + 0.0009);
3000                 NV nsver = (nver - ver) * 1000;
3001                 UV sver = (UV)(nsver + 0.0009);
3002
3003                 /* help out with the "use 5.6" confusion */
3004                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3005                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3006                         " (did you mean v%"UVuf".%03"UVuf"?)--"
3007                         "this is only v%d.%d.%d, stopped",
3008                         rev, ver, sver, rev, ver/100,
3009                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3010                 }
3011                 else {
3012                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3013                         "this is only v%d.%d.%d, stopped",
3014                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3015                         PERL_SUBVERSION);
3016                 }
3017             }
3018             RETPUSHYES;
3019         }
3020     }
3021     name = SvPV(sv, len);
3022     if (!(name && len > 0 && *name))
3023         DIE(aTHX_ "Null filename used");
3024     TAINT_PROPER("require");
3025     if (PL_op->op_type == OP_REQUIRE &&
3026       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3027       *svp != &PL_sv_undef)
3028         RETPUSHYES;
3029
3030     /* prepare to compile file */
3031
3032     if (path_is_absolute(name)) {
3033         tryname = name;
3034         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3035     }
3036 #ifdef MACOS_TRADITIONAL
3037     if (!tryrsfp) {
3038         char newname[256];
3039
3040         MacPerl_CanonDir(name, newname, 1);
3041         if (path_is_absolute(newname)) {
3042             tryname = newname;
3043             tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
3044         }
3045     }
3046 #endif
3047     if (!tryrsfp) {
3048         AV *ar = GvAVn(PL_incgv);
3049         I32 i;
3050 #ifdef VMS
3051         char *unixname;
3052         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3053 #endif
3054         {
3055             namesv = NEWSV(806, 0);
3056             for (i = 0; i <= AvFILL(ar); i++) {
3057                 SV *dirsv = *av_fetch(ar, i, TRUE);
3058
3059                 if (SvROK(dirsv)) {
3060                     int count;
3061                     SV *loader = dirsv;
3062
3063                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3064                         && !sv_isobject(loader))
3065                     {
3066                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3067                     }
3068
3069                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3070                                    PTR2UV(SvRV(dirsv)), name);
3071                     tryname = SvPVX(namesv);
3072                     tryrsfp = 0;
3073
3074                     ENTER;
3075                     SAVETMPS;
3076                     EXTEND(SP, 2);
3077
3078                     PUSHMARK(SP);
3079                     PUSHs(dirsv);
3080                     PUSHs(sv);
3081                     PUTBACK;
3082                     if (sv_isobject(loader))
3083                         count = call_method("INC", G_ARRAY);
3084                     else
3085                         count = call_sv(loader, G_ARRAY);
3086                     SPAGAIN;
3087
3088                     if (count > 0) {
3089                         int i = 0;
3090                         SV *arg;
3091
3092                         SP -= count - 1;
3093                         arg = SP[i++];
3094
3095                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3096                             arg = SvRV(arg);
3097                         }
3098
3099                         if (SvTYPE(arg) == SVt_PVGV) {
3100                             IO *io = GvIO((GV *)arg);
3101
3102                             ++filter_has_file;
3103
3104                             if (io) {
3105                                 tryrsfp = IoIFP(io);
3106                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3107                                     /* reading from a child process doesn't
3108                                        nest -- when returning from reading
3109                                        the inner module, the outer one is
3110                                        unreadable (closed?)  I've tried to
3111                                        save the gv to manage the lifespan of
3112                                        the pipe, but this didn't help. XXX */
3113                                     filter_child_proc = (GV *)arg;
3114                                     (void)SvREFCNT_inc(filter_child_proc);
3115                                 }
3116                                 else {
3117                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3118                                         PerlIO_close(IoOFP(io));
3119                                     }
3120                                     IoIFP(io) = Nullfp;
3121                                     IoOFP(io) = Nullfp;
3122                                 }
3123                             }
3124
3125                             if (i < count) {
3126                                 arg = SP[i++];
3127                             }
3128                         }
3129
3130                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3131                             filter_sub = arg;
3132                             (void)SvREFCNT_inc(filter_sub);
3133
3134                             if (i < count) {
3135                                 filter_state = SP[i];
3136                                 (void)SvREFCNT_inc(filter_state);
3137                             }
3138
3139                             if (tryrsfp == 0) {
3140                                 tryrsfp = PerlIO_open("/dev/null",
3141                                                       PERL_SCRIPT_MODE);
3142                             }
3143                         }
3144                     }
3145
3146                     PUTBACK;
3147                     FREETMPS;
3148                     LEAVE;
3149
3150                     if (tryrsfp) {
3151                         hook_sv = dirsv;
3152                         break;
3153                     }
3154
3155                     filter_has_file = 0;
3156                     if (filter_child_proc) {
3157                         SvREFCNT_dec(filter_child_proc);
3158                         filter_child_proc = 0;
3159                     }
3160                     if (filter_state) {
3161                         SvREFCNT_dec(filter_state);
3162                         filter_state = 0;
3163                     }
3164                     if (filter_sub) {
3165                         SvREFCNT_dec(filter_sub);
3166                         filter_sub = 0;
3167                     }
3168                 }
3169                 else {
3170                   if (!path_is_absolute(name)
3171 #ifdef MACOS_TRADITIONAL
3172                         /* We consider paths of the form :a:b ambiguous and interpret them first
3173                            as global then as local
3174                         */
3175                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3176 #endif
3177                   ) {
3178                     char *dir = SvPVx(dirsv, n_a);
3179 #ifdef MACOS_TRADITIONAL
3180                     char buf1[256];
3181                     char buf2[256];
3182
3183                     MacPerl_CanonDir(name, buf2, 1);
3184                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3185 #else
3186 #ifdef VMS
3187                     char *unixdir;
3188                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3189                         continue;
3190                     sv_setpv(namesv, unixdir);
3191                     sv_catpv(namesv, unixname);
3192 #else
3193                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3194 #endif
3195 #endif
3196                     TAINT_PROPER("require");
3197                     tryname = SvPVX(namesv);
3198                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3199                     if (tryrsfp) {
3200                         if (tryname[0] == '.' && tryname[1] == '/')
3201                             tryname += 2;
3202                         break;
3203                     }
3204                   }
3205                 }
3206             }
3207         }
3208     }
3209     SAVECOPFILE_FREE(&PL_compiling);
3210     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3211     SvREFCNT_dec(namesv);
3212     if (!tryrsfp) {
3213         if (PL_op->op_type == OP_REQUIRE) {
3214             char *msgstr = name;
3215             if (namesv) {                       /* did we lookup @INC? */
3216                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3217                 SV *dirmsgsv = NEWSV(0, 0);
3218                 AV *ar = GvAVn(PL_incgv);
3219                 I32 i;
3220                 sv_catpvn(msg, " in @INC", 8);
3221                 if (instr(SvPVX(msg), ".h "))
3222                     sv_catpv(msg, " (change .h to .ph maybe?)");
3223                 if (instr(SvPVX(msg), ".ph "))
3224                     sv_catpv(msg, " (did you run h2ph?)");
3225                 sv_catpv(msg, " (@INC contains:");
3226                 for (i = 0; i <= AvFILL(ar); i++) {
3227                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3228                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3229                     sv_catsv(msg, dirmsgsv);
3230                 }
3231                 sv_catpvn(msg, ")", 1);
3232                 SvREFCNT_dec(dirmsgsv);
3233                 msgstr = SvPV_nolen(msg);
3234             }
3235             DIE(aTHX_ "Can't locate %s", msgstr);
3236         }
3237
3238         RETPUSHUNDEF;
3239     }
3240     else
3241         SETERRNO(0, SS_NORMAL);
3242
3243     /* Assume success here to prevent recursive requirement. */
3244     len = strlen(name);
3245     /* Check whether a hook in @INC has already filled %INC */
3246     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3247         (void)hv_store(GvHVn(PL_incgv), name, len,
3248                        (hook_sv ? SvREFCNT_inc(hook_sv)
3249                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3250                        0 );
3251     }
3252
3253     ENTER;
3254     SAVETMPS;
3255     lex_start(sv_2mortal(newSVpvn("",0)));
3256     SAVEGENERICSV(PL_rsfp_filters);
3257     PL_rsfp_filters = Nullav;
3258
3259     PL_rsfp = tryrsfp;
3260     SAVEHINTS();
3261     PL_hints = 0;
3262     SAVESPTR(PL_compiling.cop_warnings);
3263     if (PL_dowarn & G_WARN_ALL_ON)
3264         PL_compiling.cop_warnings = pWARN_ALL ;
3265     else if (PL_dowarn & G_WARN_ALL_OFF)
3266         PL_compiling.cop_warnings = pWARN_NONE ;
3267     else if (PL_taint_warn)
3268         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3269     else
3270         PL_compiling.cop_warnings = pWARN_STD ;
3271     SAVESPTR(PL_compiling.cop_io);
3272     PL_compiling.cop_io = Nullsv;
3273
3274     if (filter_sub || filter_child_proc) {
3275         SV *datasv = filter_add(run_user_filter, Nullsv);
3276         IoLINES(datasv) = filter_has_file;
3277         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3278         IoTOP_GV(datasv) = (GV *)filter_state;
3279         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3280     }
3281
3282     /* switch to eval mode */
3283     push_return(PL_op->op_next);
3284     PUSHBLOCK(cx, CXt_EVAL, SP);
3285     PUSHEVAL(cx, name, Nullgv);
3286
3287     SAVECOPLINE(&PL_compiling);
3288     CopLINE_set(&PL_compiling, 0);
3289
3290     PUTBACK;
3291
3292     /* Store and reset encoding. */
3293     encoding = PL_encoding;
3294     PL_encoding = Nullsv;
3295
3296     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3297
3298     /* Restore encoding. */
3299     PL_encoding = encoding;
3300
3301     return op;
3302 }
3303
3304 PP(pp_dofile)
3305 {
3306     return pp_require();
3307 }
3308
3309 PP(pp_entereval)
3310 {
3311     dSP;
3312     register PERL_CONTEXT *cx;
3313     dPOPss;
3314     I32 gimme = GIMME_V, was = PL_sub_generation;
3315     char tbuf[TYPE_DIGITS(long) + 12];
3316     char *tmpbuf = tbuf;
3317     char *safestr;
3318     STRLEN len;
3319     OP *ret;
3320     CV* runcv;
3321     U32 seq;
3322
3323     if (!SvPV(sv,len))
3324         RETPUSHUNDEF;
3325     TAINT_PROPER("eval");
3326
3327     ENTER;
3328     lex_start(sv);
3329     SAVETMPS;
3330
3331     /* switch to eval mode */
3332
3333     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3334         SV *sv = sv_newmortal();
3335         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3336                        (unsigned long)++PL_evalseq,
3337                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3338         tmpbuf = SvPVX(sv);
3339     }
3340     else
3341         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3342     SAVECOPFILE_FREE(&PL_compiling);
3343     CopFILE_set(&PL_compiling, tmpbuf+2);
3344     SAVECOPLINE(&PL_compiling);
3345     CopLINE_set(&PL_compiling, 1);
3346     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3347        deleting the eval's FILEGV from the stash before gv_check() runs
3348        (i.e. before run-time proper). To work around the coredump that
3349        ensues, we always turn GvMULTI_on for any globals that were
3350        introduced within evals. See force_ident(). GSAR 96-10-12 */
3351     safestr = savepv(tmpbuf);
3352     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3353     SAVEHINTS();
3354     PL_hints = PL_op->op_targ;
3355     SAVESPTR(PL_compiling.cop_warnings);
3356     if (specialWARN(PL_curcop->cop_warnings))
3357         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3358     else {
3359         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3360         SAVEFREESV(PL_compiling.cop_warnings);
3361     }
3362     SAVESPTR(PL_compiling.cop_io);
3363     if (specialCopIO(PL_curcop->cop_io))
3364         PL_compiling.cop_io = PL_curcop->cop_io;
3365     else {
3366         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3367         SAVEFREESV(PL_compiling.cop_io);
3368     }
3369     /* special case: an eval '' executed within the DB package gets lexically
3370      * placed in the first non-DB CV rather than the current CV - this
3371      * allows the debugger to execute code, find lexicals etc, in the
3372      * scope of the code being debugged. Passing &seq gets find_runcv
3373      * to do the dirty work for us */
3374     runcv = find_runcv(&seq);
3375
3376     push_return(PL_op->op_next);
3377     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3378     PUSHEVAL(cx, 0, Nullgv);
3379
3380     /* prepare to compile string */
3381
3382     if (PERLDB_LINE && PL_curstash != PL_debstash)
3383         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3384     PUTBACK;
3385     ret = doeval(gimme, NULL, runcv, seq);
3386     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3387         && ret != PL_op->op_next) {     /* Successive compilation. */
3388         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3389     }
3390     return DOCATCH(ret);
3391 }
3392
3393 PP(pp_leaveeval)
3394 {
3395     dSP;
3396     register SV **mark;
3397     SV **newsp;
3398     PMOP *newpm;
3399     I32 gimme;
3400     register PERL_CONTEXT *cx;
3401     OP *retop;
3402     U8 save_flags = PL_op -> op_flags;
3403     I32 optype;
3404
3405     POPBLOCK(cx,newpm);
3406     POPEVAL(cx);
3407     retop = pop_return();
3408
3409     TAINT_NOT;
3410     if (gimme == G_VOID)
3411         MARK = newsp;
3412     else if (gimme == G_SCALAR) {
3413         MARK = newsp + 1;
3414         if (MARK <= SP) {
3415             if (SvFLAGS(TOPs) & SVs_TEMP)
3416                 *MARK = TOPs;
3417             else
3418                 *MARK = sv_mortalcopy(TOPs);
3419         }
3420         else {
3421             MEXTEND(mark,0);
3422             *MARK = &PL_sv_undef;
3423         }
3424         SP = MARK;
3425     }
3426     else {
3427         /* in case LEAVE wipes old return values */
3428         for (mark = newsp + 1; mark <= SP; mark++) {
3429             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3430                 *mark = sv_mortalcopy(*mark);
3431                 TAINT_NOT;      /* Each item is independent */
3432             }
3433         }
3434     }
3435     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3436
3437 #ifdef DEBUGGING
3438     assert(CvDEPTH(PL_compcv) == 1);
3439 #endif
3440     CvDEPTH(PL_compcv) = 0;
3441     lex_end();
3442
3443     if (optype == OP_REQUIRE &&
3444         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3445     {
3446         /* Unassume the success we assumed earlier. */
3447         SV *nsv = cx->blk_eval.old_namesv;
3448         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3449         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3450         /* die_where() did LEAVE, or we won't be here */
3451     }
3452     else {
3453         LEAVE;
3454         if (!(save_flags & OPf_SPECIAL))
3455             sv_setpv(ERRSV,"");
3456     }
3457
3458     RETURNOP(retop);
3459 }
3460
3461 PP(pp_entertry)
3462 {
3463     dSP;
3464     register PERL_CONTEXT *cx;
3465     I32 gimme = GIMME_V;
3466
3467     ENTER;
3468     SAVETMPS;
3469
3470     push_return(cLOGOP->op_other->op_next);
3471     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3472     PUSHEVAL(cx, 0, 0);
3473
3474     PL_in_eval = EVAL_INEVAL;
3475     sv_setpv(ERRSV,"");
3476     PUTBACK;
3477     return DOCATCH(PL_op->op_next);
3478 }
3479
3480 PP(pp_leavetry)
3481 {
3482     dSP;
3483     register SV **mark;
3484     SV **newsp;
3485     PMOP *newpm;
3486     OP* retop;
3487     I32 gimme;
3488     register PERL_CONTEXT *cx;
3489     I32 optype;
3490
3491     POPBLOCK(cx,newpm);
3492     POPEVAL(cx);
3493     retop = pop_return();
3494
3495     TAINT_NOT;
3496     if (gimme == G_VOID)
3497         SP = newsp;
3498     else if (gimme == G_SCALAR) {
3499         MARK = newsp + 1;
3500         if (MARK <= SP) {
3501             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3502                 *MARK = TOPs;
3503             else
3504                 *MARK = sv_mortalcopy(TOPs);
3505         }
3506         else {
3507             MEXTEND(mark,0);
3508             *MARK = &PL_sv_undef;
3509         }
3510         SP = MARK;
3511     }
3512     else {
3513         /* in case LEAVE wipes old return values */
3514         for (mark = newsp + 1; mark <= SP; mark++) {
3515             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3516                 *mark = sv_mortalcopy(*mark);
3517                 TAINT_NOT;      /* Each item is independent */
3518             }
3519         }
3520     }
3521     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3522
3523     LEAVE;
3524     sv_setpv(ERRSV,"");
3525     RETURNOP(retop);
3526 }
3527
3528 STATIC void
3529 S_doparseform(pTHX_ SV *sv)
3530 {
3531     STRLEN len;
3532     register char *s = SvPV_force(sv, len);
3533     register char *send = s + len;
3534     register char *base = Nullch;
3535     register I32 skipspaces = 0;
3536     bool noblank   = FALSE;
3537     bool repeat    = FALSE;
3538     bool postspace = FALSE;
3539     U16 *fops;
3540     register U16 *fpc;
3541     U16 *linepc = 0;
3542     register I32 arg;
3543     bool ischop;
3544
3545     if (len == 0)
3546         Perl_croak(aTHX_ "Null picture in formline");
3547
3548     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3549     fpc = fops;
3550
3551     if (s < send) {
3552         linepc = fpc;
3553         *fpc++ = FF_LINEMARK;
3554         noblank = repeat = FALSE;
3555         base = s;
3556     }
3557
3558     while (s <= send) {
3559         switch (*s++) {
3560         default:
3561             skipspaces = 0;
3562             continue;
3563
3564         case '~':
3565             if (*s == '~') {
3566                 repeat = TRUE;
3567                 *s = ' ';
3568             }
3569             noblank = TRUE;
3570             s[-1] = ' ';
3571             /* FALL THROUGH */
3572         case ' ': case '\t':
3573             skipspaces++;
3574             continue;
3575
3576         case '\n': case 0:
3577             arg = s - base;
3578             skipspaces++;
3579             arg -= skipspaces;
3580             if (arg) {
3581                 if (postspace)
3582                     *fpc++ = FF_SPACE;
3583                 *fpc++ = FF_LITERAL;
3584                 *fpc++ = (U16)arg;
3585             }
3586             postspace = FALSE;
3587             if (s <= send)
3588                 skipspaces--;
3589             if (skipspaces) {
3590                 *fpc++ = FF_SKIP;
3591                 *fpc++ = (U16)skipspaces;
3592             }
3593             skipspaces = 0;
3594             if (s <= send)
3595                 *fpc++ = FF_NEWLINE;
3596             if (noblank) {
3597                 *fpc++ = FF_BLANK;
3598                 if (repeat)
3599                     arg = fpc - linepc + 1;
3600                 else
3601                     arg = 0;
3602                 *fpc++ = (U16)arg;
3603             }
3604             if (s < send) {
3605                 linepc = fpc;
3606                 *fpc++ = FF_LINEMARK;
3607                 noblank = repeat = FALSE;
3608                 base = s;
3609             }
3610             else
3611                 s++;
3612             continue;
3613
3614         case '@':
3615         case '^':
3616             ischop = s[-1] == '^';
3617
3618             if (postspace) {
3619                 *fpc++ = FF_SPACE;
3620                 postspace = FALSE;
3621             }
3622             arg = (s - base) - 1;
3623             if (arg) {
3624                 *fpc++ = FF_LITERAL;
3625                 *fpc++ = (U16)arg;
3626             }
3627
3628             base = s - 1;
3629             *fpc++ = FF_FETCH;
3630             if (*s == '*') {
3631                 s++;
3632                 *fpc++ = 0;
3633                 *fpc++ = FF_LINEGLOB;
3634             }
3635             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3636                 arg = ischop ? 512 : 0;
3637                 base = s - 1;
3638                 while (*s == '#')
3639                     s++;
3640                 if (*s == '.') {
3641                     char *f;
3642                     s++;
3643                     f = s;
3644                     while (*s == '#')
3645                         s++;
3646                     arg |= 256 + (s - f);
3647                 }
3648                 *fpc++ = s - base;              /* fieldsize for FETCH */
3649                 *fpc++ = FF_DECIMAL;
3650                 *fpc++ = (U16)arg;
3651             }
3652             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3653                 arg = ischop ? 512 : 0;
3654                 base = s - 1;
3655                 s++;                                /* skip the '0' first */
3656                 while (*s == '#')
3657                     s++;
3658                 if (*s == '.') {
3659                     char *f;
3660                     s++;
3661                     f = s;
3662                     while (*s == '#')
3663                         s++;
3664                     arg |= 256 + (s - f);
3665                 }
3666                 *fpc++ = s - base;                /* fieldsize for FETCH */
3667                 *fpc++ = FF_0DECIMAL;
3668                 *fpc++ = (U16)arg;
3669             }
3670             else {
3671                 I32 prespace = 0;
3672                 bool ismore = FALSE;
3673
3674                 if (*s == '>') {
3675                     while (*++s == '>') ;
3676                     prespace = FF_SPACE;
3677                 }
3678                 else if (*s == '|') {
3679                     while (*++s == '|') ;
3680                     prespace = FF_HALFSPACE;
3681                     postspace = TRUE;
3682                 }
3683                 else {
3684                     if (*s == '<')
3685                         while (*++s == '<') ;
3686                     postspace = TRUE;
3687                 }
3688                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3689                     s += 3;
3690                     ismore = TRUE;
3691                 }
3692                 *fpc++ = s - base;              /* fieldsize for FETCH */
3693
3694                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3695
3696                 if (prespace)
3697                     *fpc++ = (U16)prespace;
3698                 *fpc++ = FF_ITEM;
3699                 if (ismore)
3700                     *fpc++ = FF_MORE;
3701                 if (ischop)
3702                     *fpc++ = FF_CHOP;
3703             }
3704             base = s;
3705             skipspaces = 0;
3706             continue;
3707         }
3708     }
3709     *fpc++ = FF_END;
3710
3711     arg = fpc - fops;
3712     { /* need to jump to the next word */
3713         int z;
3714         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3715         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3716         s = SvPVX(sv) + SvCUR(sv) + z;
3717     }
3718     Copy(fops, s, arg, U16);
3719     Safefree(fops);
3720     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3721     SvCOMPILED_on(sv);
3722 }
3723
3724 static I32
3725 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3726 {
3727     SV *datasv = FILTER_DATA(idx);
3728     int filter_has_file = IoLINES(datasv);
3729     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3730     SV *filter_state = (SV *)IoTOP_GV(datasv);
3731     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3732     int len = 0;
3733
3734     /* I was having segfault trouble under Linux 2.2.5 after a
3735        parse error occured.  (Had to hack around it with a test
3736        for PL_error_count == 0.)  Solaris doesn't segfault --
3737        not sure where the trouble is yet.  XXX */
3738
3739     if (filter_has_file) {
3740         len = FILTER_READ(idx+1, buf_sv, maxlen);
3741     }
3742
3743     if (filter_sub && len >= 0) {
3744         dSP;
3745         int count;
3746
3747         ENTER;
3748         SAVE_DEFSV;
3749         SAVETMPS;
3750         EXTEND(SP, 2);
3751
3752         DEFSV = buf_sv;
3753         PUSHMARK(SP);
3754         PUSHs(sv_2mortal(newSViv(maxlen)));
3755         if (filter_state) {
3756             PUSHs(filter_state);
3757         }
3758         PUTBACK;
3759         count = call_sv(filter_sub, G_SCALAR);
3760         SPAGAIN;
3761
3762         if (count > 0) {
3763             SV *out = POPs;
3764             if (SvOK(out)) {
3765                 len = SvIV(out);
3766             }
3767         }
3768
3769         PUTBACK;
3770         FREETMPS;
3771         LEAVE;
3772     }
3773
3774     if (len <= 0) {
3775         IoLINES(datasv) = 0;
3776         if (filter_child_proc) {
3777             SvREFCNT_dec(filter_child_proc);
3778             IoFMT_GV(datasv) = Nullgv;
3779         }
3780         if (filter_state) {
3781             SvREFCNT_dec(filter_state);
3782             IoTOP_GV(datasv) = Nullgv;
3783         }
3784         if (filter_sub) {
3785             SvREFCNT_dec(filter_sub);
3786             IoBOTTOM_GV(datasv) = Nullgv;
3787         }
3788         filter_del(run_user_filter);
3789     }
3790
3791     return len;
3792 }
3793
3794 /* perhaps someone can come up with a better name for
3795    this?  it is not really "absolute", per se ... */
3796 static bool
3797 S_path_is_absolute(pTHX_ char *name)
3798 {
3799     if (PERL_FILE_IS_ABSOLUTE(name)
3800 #ifdef MACOS_TRADITIONAL
3801         || (*name == ':'))
3802 #else
3803         || (*name == '.' && (name[1] == '/' ||
3804                              (name[1] == '.' && name[2] == '/'))))
3805 #endif
3806     {
3807         return TRUE;
3808     }
3809     else
3810         return FALSE;
3811 }