pp_ctl.c

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