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 = Nullsv;
 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, Nullsv, PERL_MAGIC_regex_global, Nullch, 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 : Nullch);
 318     RX_MATCH_COPIED_off(rx);
 319
 320 #ifdef PERL_OLD_COPY_ON_WRITE
 321     *p++ = PTR2UV(rx->saved_copy);
 322     rx->saved_copy = Nullsv;
 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 = Nullsv;
 395     const char *item = Nullch;
 396     I32 itemsize  = 0;
 397     I32 fieldsize = 0;
 398     I32 lines = 0;
 399     bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
 400     const char *chophere = Nullch;
 401     char *linemark = Nullch;
 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 = Nullsv;
 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 = Nullch;
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 = Nullch;
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, Nullch);
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 = Nullsv;
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 = Nullsv;
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, Nullch);
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), Nullch);
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     int st_rc;
3035     st_rc = PerlLIO_stat(name, &st);
3036     if (st_rc < 0) {
3037        return Nullfp;
3038     }
3039
3040     if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3041        Perl_die(aTHX_ "%s %s not allowed in require",
3042            S_ISDIR(st.st_mode) ? "Directory" : "Block device", name);
3043     }
3044     return PerlIO_open(name, mode);
3045 }
3046
3047 STATIC PerlIO *
3048 S_doopen_pm(pTHX_ const char *name, const char *mode)
3049 {
3050 #ifndef PERL_DISABLE_PMC
3051     const STRLEN namelen = strlen(name);
3052     PerlIO *fp;
3053
3054     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3055         SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3056         const char * const pmc = SvPV_nolen_const(pmcsv);
3057         Stat_t pmcstat;
3058         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3059             fp = check_type_and_open(name, mode);
3060         }
3061         else {
3062             Stat_t pmstat;
3063             if (PerlLIO_stat(name, &pmstat) < 0 ||
3064                 pmstat.st_mtime < pmcstat.st_mtime)
3065             {
3066                 fp = check_type_and_open(pmc, mode);
3067             }
3068             else {
3069                 fp = check_type_and_open(name, mode);
3070             }
3071         }
3072         SvREFCNT_dec(pmcsv);
3073     }
3074     else {
3075         fp = check_type_and_open(name, mode);
3076     }
3077     return fp;
3078 #else
3079     return check_type_and_open(name, mode);
3080 #endif /* !PERL_DISABLE_PMC */
3081 }
3082
3083 PP(pp_require)
3084 {
3085     dVAR; dSP;
3086     register PERL_CONTEXT *cx;
3087     SV *sv;
3088     const char *name;
3089     STRLEN len;
3090     const char *tryname = Nullch;
3091     SV *namesv = Nullsv;
3092     const I32 gimme = GIMME_V;
3093     PerlIO *tryrsfp = 0;
3094     int filter_has_file = 0;
3095     GV *filter_child_proc = 0;
3096     SV *filter_state = 0;
3097     SV *filter_sub = 0;
3098     SV *hook_sv = 0;
3099     SV *encoding;
3100     OP *op;
3101
3102     sv = POPs;
3103     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3104         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )       /* require v5.6.1 */
3105                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3106                         "v-string in use/require non-portable");
3107
3108         sv = new_version(sv);
3109         if (!sv_derived_from(PL_patchlevel, "version"))
3110             (void *)upg_version(PL_patchlevel);
3111         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3112             if ( vcmp(sv,PL_patchlevel) < 0 )
3113                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3114                     vnormal(sv), vnormal(PL_patchlevel));
3115         }
3116         else {
3117             if ( vcmp(sv,PL_patchlevel) > 0 )
3118                 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3119                     vnormal(sv), vnormal(PL_patchlevel));
3120         }
3121
3122             RETPUSHYES;
3123     }
3124     name = SvPV_const(sv, len);
3125     if (!(name && len > 0 && *name))
3126         DIE(aTHX_ "Null filename used");
3127     TAINT_PROPER("require");
3128     if (PL_op->op_type == OP_REQUIRE) {
3129         SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3130         if ( svp ) {
3131             if (*svp != &PL_sv_undef)
3132                 RETPUSHYES;
3133             else
3134                 DIE(aTHX_ "Compilation failed in require");
3135         }
3136     }
3137
3138     /* prepare to compile file */
3139
3140     if (path_is_absolute(name)) {
3141         tryname = name;
3142         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3143     }
3144 #ifdef MACOS_TRADITIONAL
3145     if (!tryrsfp) {
3146         char newname[256];
3147
3148         MacPerl_CanonDir(name, newname, 1);
3149         if (path_is_absolute(newname)) {
3150             tryname = newname;
3151             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3152         }
3153     }
3154 #endif
3155     if (!tryrsfp) {
3156         AV * const ar = GvAVn(PL_incgv);
3157         I32 i;
3158 #ifdef VMS
3159         char *unixname;
3160         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3161 #endif
3162         {
3163             namesv = NEWSV(806, 0);
3164             for (i = 0; i <= AvFILL(ar); i++) {
3165                 SV *dirsv = *av_fetch(ar, i, TRUE);
3166
3167                 if (SvROK(dirsv)) {
3168                     int count;
3169                     SV *loader = dirsv;
3170
3171                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3172                         && !sv_isobject(loader))
3173                     {
3174                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3175                     }
3176
3177                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3178                                    PTR2UV(SvRV(dirsv)), name);
3179                     tryname = SvPVX_const(namesv);
3180                     tryrsfp = 0;
3181
3182                     ENTER;
3183                     SAVETMPS;
3184                     EXTEND(SP, 2);
3185
3186                     PUSHMARK(SP);
3187                     PUSHs(dirsv);
3188                     PUSHs(sv);
3189                     PUTBACK;
3190                     if (sv_isobject(loader))
3191                         count = call_method("INC", G_ARRAY);
3192                     else
3193                         count = call_sv(loader, G_ARRAY);
3194                     SPAGAIN;
3195
3196                     if (count > 0) {
3197                         int i = 0;
3198                         SV *arg;
3199
3200                         SP -= count - 1;
3201                         arg = SP[i++];
3202
3203                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3204                             arg = SvRV(arg);
3205                         }
3206
3207                         if (SvTYPE(arg) == SVt_PVGV) {
3208                             IO *io = GvIO((GV *)arg);
3209
3210                             ++filter_has_file;
3211
3212                             if (io) {
3213                                 tryrsfp = IoIFP(io);
3214                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3215                                     /* reading from a child process doesn't
3216                                        nest -- when returning from reading
3217                                        the inner module, the outer one is
3218                                        unreadable (closed?)  I've tried to
3219                                        save the gv to manage the lifespan of
3220                                        the pipe, but this didn't help. XXX */
3221                                     filter_child_proc = (GV *)arg;
3222                                     (void)SvREFCNT_inc(filter_child_proc);
3223                                 }
3224                                 else {
3225                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3226                                         PerlIO_close(IoOFP(io));
3227                                     }
3228                                     IoIFP(io) = Nullfp;
3229                                     IoOFP(io) = Nullfp;
3230                                 }
3231                             }
3232
3233                             if (i < count) {
3234                                 arg = SP[i++];
3235                             }
3236                         }
3237
3238                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3239                             filter_sub = arg;
3240                             (void)SvREFCNT_inc(filter_sub);
3241
3242                             if (i < count) {
3243                                 filter_state = SP[i];
3244                                 (void)SvREFCNT_inc(filter_state);
3245                             }
3246
3247                             if (tryrsfp == 0) {
3248                                 tryrsfp = PerlIO_open("/dev/null",
3249                                                       PERL_SCRIPT_MODE);
3250                             }
3251                         }
3252                         SP--;
3253                     }
3254
3255                     PUTBACK;
3256                     FREETMPS;
3257                     LEAVE;
3258
3259                     if (tryrsfp) {
3260                         hook_sv = dirsv;
3261                         break;
3262                     }
3263
3264                     filter_has_file = 0;
3265                     if (filter_child_proc) {
3266                         SvREFCNT_dec(filter_child_proc);
3267                         filter_child_proc = 0;
3268                     }
3269                     if (filter_state) {
3270                         SvREFCNT_dec(filter_state);
3271                         filter_state = 0;
3272                     }
3273                     if (filter_sub) {
3274                         SvREFCNT_dec(filter_sub);
3275                         filter_sub = 0;
3276                     }
3277                 }
3278                 else {
3279                   if (!path_is_absolute(name)
3280 #ifdef MACOS_TRADITIONAL
3281                         /* We consider paths of the form :a:b ambiguous and interpret them first
3282                            as global then as local
3283                         */
3284                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3285 #endif
3286                   ) {
3287                     const char *dir = SvPVx_nolen_const(dirsv);
3288 #ifdef MACOS_TRADITIONAL
3289                     char buf1[256];
3290                     char buf2[256];
3291
3292                     MacPerl_CanonDir(name, buf2, 1);
3293                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3294 #else
3295 #  ifdef VMS
3296                     char *unixdir;
3297                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3298                         continue;
3299                     sv_setpv(namesv, unixdir);
3300                     sv_catpv(namesv, unixname);
3301 #  else
3302 #    ifdef __SYMBIAN32__
3303                     if (PL_origfilename[0] &&
3304                         PL_origfilename[1] == ':' &&
3305                         !(dir[0] && dir[1] == ':'))
3306                         Perl_sv_setpvf(aTHX_ namesv,
3307                                        "%c:%s\\%s",
3308                                        PL_origfilename[0],
3309                                        dir, name);
3310                     else
3311                         Perl_sv_setpvf(aTHX_ namesv,
3312                                        "%s\\%s",
3313                                        dir, name);
3314 #    else
3315                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3316 #    endif
3317 #  endif
3318 #endif
3319                     TAINT_PROPER("require");
3320                     tryname = SvPVX_const(namesv);
3321                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3322                     if (tryrsfp) {
3323                         if (tryname[0] == '.' && tryname[1] == '/')
3324                             tryname += 2;
3325                         break;
3326                     }
3327                   }
3328                 }
3329             }
3330         }
3331     }
3332     SAVECOPFILE_FREE(&PL_compiling);
3333     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3334     SvREFCNT_dec(namesv);
3335     if (!tryrsfp) {
3336         if (PL_op->op_type == OP_REQUIRE) {
3337             const char *msgstr = name;
3338             if(errno == EMFILE) {
3339                 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3340                 sv_catpv(msg, ":  ");
3341                 sv_catpv(msg, Strerror(errno));
3342                 msgstr = SvPV_nolen_const(msg);
3343             } else {
3344                 if (namesv) {                   /* did we lookup @INC? */
3345                     SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3346                     SV * const dirmsgsv = NEWSV(0, 0);
3347                     AV * const ar = GvAVn(PL_incgv);
3348                     I32 i;
3349                     sv_catpvn(msg, " in @INC", 8);
3350                     if (instr(SvPVX_const(msg), ".h "))
3351                         sv_catpv(msg, " (change .h to .ph maybe?)");
3352                     if (instr(SvPVX_const(msg), ".ph "))
3353                         sv_catpv(msg, " (did you run h2ph?)");
3354                     sv_catpv(msg, " (@INC contains:");
3355                     for (i = 0; i <= AvFILL(ar); i++) {
3356                         const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3357                         Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3358                         sv_catsv(msg, dirmsgsv);
3359                     }
3360                     sv_catpvn(msg, ")", 1);
3361                     SvREFCNT_dec(dirmsgsv);
3362                     msgstr = SvPV_nolen_const(msg);
3363                 }
3364             }
3365             DIE(aTHX_ "Can't locate %s", msgstr);
3366         }
3367
3368         RETPUSHUNDEF;
3369     }
3370     else
3371         SETERRNO(0, SS_NORMAL);
3372
3373     /* Assume success here to prevent recursive requirement. */
3374     /* name is never assigned to again, so len is still strlen(name)  */
3375     /* Check whether a hook in @INC has already filled %INC */
3376     if (!hook_sv) {
3377         (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3378     } else {
3379         SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3380         if (!svp)
3381             (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
3382     }
3383
3384     ENTER;
3385     SAVETMPS;
3386     lex_start(sv_2mortal(newSVpvn("",0)));
3387     SAVEGENERICSV(PL_rsfp_filters);
3388     PL_rsfp_filters = NULL;
3389
3390     PL_rsfp = tryrsfp;
3391     SAVEHINTS();
3392     PL_hints = 0;
3393     SAVESPTR(PL_compiling.cop_warnings);
3394     if (PL_dowarn & G_WARN_ALL_ON)
3395         PL_compiling.cop_warnings = pWARN_ALL ;
3396     else if (PL_dowarn & G_WARN_ALL_OFF)
3397         PL_compiling.cop_warnings = pWARN_NONE ;
3398     else if (PL_taint_warn)
3399         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3400     else
3401         PL_compiling.cop_warnings = pWARN_STD ;
3402     SAVESPTR(PL_compiling.cop_io);
3403     PL_compiling.cop_io = Nullsv;
3404
3405     if (filter_sub || filter_child_proc) {
3406         SV * const datasv = filter_add(S_run_user_filter, Nullsv);
3407         IoLINES(datasv) = filter_has_file;
3408         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3409         IoTOP_GV(datasv) = (GV *)filter_state;
3410         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3411     }
3412
3413     /* switch to eval mode */
3414     PUSHBLOCK(cx, CXt_EVAL, SP);
3415     PUSHEVAL(cx, name, Nullgv);
3416     cx->blk_eval.retop = PL_op->op_next;
3417
3418     SAVECOPLINE(&PL_compiling);
3419     CopLINE_set(&PL_compiling, 0);
3420
3421     PUTBACK;
3422
3423     /* Store and reset encoding. */
3424     encoding = PL_encoding;
3425     PL_encoding = Nullsv;
3426
3427     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3428
3429     /* Restore encoding. */
3430     PL_encoding = encoding;
3431
3432     return op;
3433 }
3434
3435 PP(pp_entereval)
3436 {
3437     dVAR; dSP;
3438     register PERL_CONTEXT *cx;
3439     SV *sv;
3440     const I32 gimme = GIMME_V;
3441     const I32 was = PL_sub_generation;
3442     char tbuf[TYPE_DIGITS(long) + 12];
3443     char *tmpbuf = tbuf;
3444     char *safestr;
3445     STRLEN len;
3446     OP *ret;
3447     CV* runcv;
3448     U32 seq;
3449     HV *saved_hh = 0;
3450
3451     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3452         saved_hh = (HV*) SvREFCNT_inc(POPs);
3453     }
3454     sv = POPs;
3455
3456     if (!SvPV_nolen_const(sv))
3457         RETPUSHUNDEF;
3458     TAINT_PROPER("eval");
3459
3460     ENTER;
3461     lex_start(sv);
3462     SAVETMPS;
3463
3464     /* switch to eval mode */
3465
3466     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3467         SV * const sv = sv_newmortal();
3468         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3469                        (unsigned long)++PL_evalseq,
3470                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3471         tmpbuf = SvPVX(sv);
3472         len = SvCUR(sv);
3473     }
3474     else
3475         len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3476     SAVECOPFILE_FREE(&PL_compiling);
3477     CopFILE_set(&PL_compiling, tmpbuf+2);
3478     SAVECOPLINE(&PL_compiling);
3479     CopLINE_set(&PL_compiling, 1);
3480     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3481        deleting the eval's FILEGV from the stash before gv_check() runs
3482        (i.e. before run-time proper). To work around the coredump that
3483        ensues, we always turn GvMULTI_on for any globals that were
3484        introduced within evals. See force_ident(). GSAR 96-10-12 */
3485     safestr = savepvn(tmpbuf, len);
3486     SAVEDELETE(PL_defstash, safestr, len);
3487     SAVEHINTS();
3488     PL_hints = PL_op->op_targ;
3489     if (saved_hh)
3490         GvHV(PL_hintgv) = saved_hh;
3491     SAVESPTR(PL_compiling.cop_warnings);
3492     if (specialWARN(PL_curcop->cop_warnings))
3493         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3494     else {
3495         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3496         SAVEFREESV(PL_compiling.cop_warnings);
3497     }
3498     SAVESPTR(PL_compiling.cop_io);
3499     if (specialCopIO(PL_curcop->cop_io))
3500         PL_compiling.cop_io = PL_curcop->cop_io;
3501     else {
3502         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3503         SAVEFREESV(PL_compiling.cop_io);
3504     }
3505     /* special case: an eval '' executed within the DB package gets lexically
3506      * placed in the first non-DB CV rather than the current CV - this
3507      * allows the debugger to execute code, find lexicals etc, in the
3508      * scope of the code being debugged. Passing &seq gets find_runcv
3509      * to do the dirty work for us */
3510     runcv = find_runcv(&seq);
3511
3512     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3513     PUSHEVAL(cx, 0, Nullgv);
3514     cx->blk_eval.retop = PL_op->op_next;
3515
3516     /* prepare to compile string */
3517
3518     if (PERLDB_LINE && PL_curstash != PL_debstash)
3519         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3520     PUTBACK;
3521     ret = doeval(gimme, NULL, runcv, seq);
3522     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3523         && ret != PL_op->op_next) {     /* Successive compilation. */
3524         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3525     }
3526     return DOCATCH(ret);
3527 }
3528
3529 PP(pp_leaveeval)
3530 {
3531     dVAR; dSP;
3532     register SV **mark;
3533     SV **newsp;
3534     PMOP *newpm;
3535     I32 gimme;
3536     register PERL_CONTEXT *cx;
3537     OP *retop;
3538     const U8 save_flags = PL_op -> op_flags;
3539     I32 optype;
3540
3541     POPBLOCK(cx,newpm);
3542     POPEVAL(cx);
3543     retop = cx->blk_eval.retop;
3544
3545     TAINT_NOT;
3546     if (gimme == G_VOID)
3547         MARK = newsp;
3548     else if (gimme == G_SCALAR) {
3549         MARK = newsp + 1;
3550         if (MARK <= SP) {
3551             if (SvFLAGS(TOPs) & SVs_TEMP)
3552                 *MARK = TOPs;
3553             else
3554                 *MARK = sv_mortalcopy(TOPs);
3555         }
3556         else {
3557             MEXTEND(mark,0);
3558             *MARK = &PL_sv_undef;
3559         }
3560         SP = MARK;
3561     }
3562     else {
3563         /* in case LEAVE wipes old return values */
3564         for (mark = newsp + 1; mark <= SP; mark++) {
3565             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3566                 *mark = sv_mortalcopy(*mark);
3567                 TAINT_NOT;      /* Each item is independent */
3568             }
3569         }
3570     }
3571     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3572
3573 #ifdef DEBUGGING
3574     assert(CvDEPTH(PL_compcv) == 1);
3575 #endif
3576     CvDEPTH(PL_compcv) = 0;
3577     lex_end();
3578
3579     if (optype == OP_REQUIRE &&
3580         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3581     {
3582         /* Unassume the success we assumed earlier. */
3583         SV * const nsv = cx->blk_eval.old_namesv;
3584         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3585         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3586         /* die_where() did LEAVE, or we won't be here */
3587     }
3588     else {
3589         LEAVE;
3590         if (!(save_flags & OPf_SPECIAL))
3591             sv_setpvn(ERRSV,"",0);
3592     }
3593
3594     RETURNOP(retop);
3595 }
3596
3597 PP(pp_entertry)
3598 {
3599     dVAR; dSP;
3600     register PERL_CONTEXT *cx;
3601     const I32 gimme = GIMME_V;
3602
3603     ENTER;
3604     SAVETMPS;
3605
3606     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3607     PUSHEVAL(cx, 0, 0);
3608     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3609
3610     PL_in_eval = EVAL_INEVAL;
3611     sv_setpvn(ERRSV,"",0);
3612     PUTBACK;
3613     return DOCATCH(PL_op->op_next);
3614 }
3615
3616 PP(pp_leavetry)
3617 {
3618     dVAR; dSP;
3619     register SV **mark;
3620     SV **newsp;
3621     PMOP *newpm;
3622     I32 gimme;
3623     register PERL_CONTEXT *cx;
3624     I32 optype;
3625
3626     POPBLOCK(cx,newpm);
3627     POPEVAL(cx);
3628     PERL_UNUSED_VAR(optype);
3629
3630     TAINT_NOT;
3631     if (gimme == G_VOID)
3632         SP = newsp;
3633     else if (gimme == G_SCALAR) {
3634         MARK = newsp + 1;
3635         if (MARK <= SP) {
3636             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3637                 *MARK = TOPs;
3638             else
3639                 *MARK = sv_mortalcopy(TOPs);
3640         }
3641         else {
3642             MEXTEND(mark,0);
3643             *MARK = &PL_sv_undef;
3644         }
3645         SP = MARK;
3646     }
3647     else {
3648         /* in case LEAVE wipes old return values */
3649         for (mark = newsp + 1; mark <= SP; mark++) {
3650             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3651                 *mark = sv_mortalcopy(*mark);
3652                 TAINT_NOT;      /* Each item is independent */
3653             }
3654         }
3655     }
3656     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3657
3658     LEAVE;
3659     sv_setpvn(ERRSV,"",0);
3660     RETURN;
3661 }
3662
3663 PP(pp_entergiven)
3664 {
3665     dVAR; dSP;
3666     register PERL_CONTEXT *cx;
3667     const I32 gimme = GIMME_V;
3668
3669     ENTER;
3670     SAVETMPS;
3671
3672     if (PL_op->op_targ == 0) {
3673         SV **defsv_p = &GvSV(PL_defgv);
3674         *defsv_p = newSVsv(POPs);
3675         SAVECLEARSV(*defsv_p);
3676     }
3677     else
3678         sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3679
3680     PUSHBLOCK(cx, CXt_GIVEN, SP);
3681     PUSHGIVEN(cx);
3682
3683     RETURN;
3684 }
3685
3686 PP(pp_leavegiven)
3687 {
3688     dVAR; dSP;
3689     register PERL_CONTEXT *cx;
3690     I32 gimme;
3691     SV **newsp;
3692     PMOP *newpm;
3693     SV **mark;
3694
3695     POPBLOCK(cx,newpm);
3696     assert(CxTYPE(cx) == CXt_GIVEN);
3697     mark = newsp;
3698
3699     SP = newsp;
3700     PUTBACK;
3701
3702     PL_curpm = newpm;   /* pop $1 et al */
3703
3704     LEAVE;
3705
3706     return NORMAL;
3707 }
3708
3709 /* Helper routines used by pp_smartmatch */
3710 STATIC
3711 PMOP *
3712 S_make_matcher(pTHX_ regexp *re)
3713 {
3714     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3715     PM_SETRE(matcher, ReREFCNT_inc(re));
3716
3717     SAVEFREEOP((OP *) matcher);
3718     ENTER; SAVETMPS;
3719     SAVEOP();
3720     return matcher;
3721 }
3722
3723 STATIC
3724 bool
3725 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3726 {
3727     dSP;
3728
3729     PL_op = (OP *) matcher;
3730     XPUSHs(sv);
3731     PUTBACK;
3732     (void) pp_match();
3733     SPAGAIN;
3734     return (SvTRUEx(POPs));
3735 }
3736
3737 STATIC
3738 void
3739 S_destroy_matcher(pTHX_ PMOP *matcher)
3740 {
3741     PERL_UNUSED_ARG(matcher);
3742     FREETMPS;
3743     LEAVE;
3744 }
3745
3746 /* Do a smart match */
3747 PP(pp_smartmatch)
3748 {
3749     return do_smartmatch(Nullhv, Nullhv);
3750 }
3751
3752 /* This version of do_smartmatch() implements the following
3753    table of smart matches:
3754
3755     $a      $b        Type of Match Implied    Matching Code
3756     ======  =====     =====================    =============
3757     (overloading trumps everything)
3758
3759     Code[+] Code[+]   referential equality     match if refaddr($a) == refaddr($b)
3760     Any     Code[+]   scalar sub truth         match if $b->($a)
3761
3762     Hash    Hash      hash keys identical      match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b))
3763     Hash    Array     hash value slice truth   match if $a->{any(@$b)}
3764     Hash    Regex     hash key grep            match if any(keys(%$a)) =~ /$b/
3765     Hash    Any       hash entry existence     match if exists $a->{$b}
3766
3767     Array   Array     arrays are identical[*]  match if $a È~~Ç $b
3768     Array   Regex     array grep               match if any(@$a) =~ /$b/
3769     Array   Num       array contains number    match if any($a) == $b
3770     Array   Any       array contains string    match if any($a) eq $b
3771
3772     Any     undef     undefined                match if !defined $a
3773     Any     Regex     pattern match            match if $a =~ /$b/
3774     Code()  Code()    results are equal        match if $a->() eq $b->()
3775     Any     Code()    simple closure truth     match if $b->() (ignoring $a)
3776     Num     numish[!] numeric equality         match if $a == $b
3777     Any     Str       string equality          match if $a eq $b
3778     Any     Num       numeric equality         match if $a == $b
3779
3780     Any     Any       string equality          match if $a eq $b
3781
3782
3783  + - this must be a code reference whose prototype (if present) is not ""
3784      (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
3785  * - if a circular reference is found, we fall back to referential equality
3786  ! - either a real number, or a string that looks_like_number()
3787
3788  */
3789 STATIC
3790 OP *
3791 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3792 {
3793     dSP;
3794
3795     SV *e = TOPs;       /* e is for 'expression' */
3796     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
3797     SV *this, *other;
3798     MAGIC *mg;
3799     regexp *this_regex, *other_regex;
3800
3801 #   define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3802
3803 #   define SM_REF(type) ( \
3804            (SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_##type) && (other = e)) \
3805         || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_##type) && (other = d)))
3806
3807 #   define SM_CV_NEP   /* Find a code ref without an empty prototype */ \
3808         ((SvROK(d) && (SvTYPE(this = SvRV(d)) == SVt_PVCV)              \
3809             && NOT_EMPTY_PROTO(this) && (other = e))                    \
3810         || (SvROK(e) && (SvTYPE(this = SvRV(e)) == SVt_PVCV)            \
3811             && NOT_EMPTY_PROTO(this) && (other = d)))
3812
3813 #   define SM_REGEX ( \
3814            (SvROK(d) && SvMAGICAL(this = SvRV(d))                       \
3815         && (mg = mg_find(this, PERL_MAGIC_qr))                          \
3816         && (this_regex = (regexp *)mg->mg_obj)                          \
3817         && (other = e))                                                 \
3818     ||                                                                  \
3819            (SvROK(e) && SvMAGICAL(this = SvRV(e))                       \
3820         && (mg = mg_find(this, PERL_MAGIC_qr))                          \
3821         && (this_regex = (regexp *)mg->mg_obj)                          \
3822         && (other = d)) )
3823
3824
3825 #   define SM_OTHER_REF(type) \
3826         (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##type)
3827
3828 #   define SM_OTHER_REGEX (SvROK(other) && SvMAGICAL(SvRV(other))       \
3829         && (mg = mg_find(SvRV(other), PERL_MAGIC_qr))                   \
3830         && (other_regex = (regexp *)mg->mg_obj))
3831
3832
3833 #   define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3834         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3835
3836 #   define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3837         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3838
3839     tryAMAGICbinSET(smart, 0);
3840
3841     SP -= 2;    /* Pop the values */
3842
3843     /* Take care only to invoke mg_get() once for each argument.
3844      * Currently we do this by copying the SV if it's magical. */
3845     if (d) {
3846         if (SvGMAGICAL(d))
3847             d = sv_mortalcopy(d);
3848     }
3849     else
3850         d = &PL_sv_undef;
3851
3852     assert(e);
3853     if (SvGMAGICAL(e))
3854         e = sv_mortalcopy(e);
3855
3856     if (SM_CV_NEP) {
3857         I32 c;
3858
3859         if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) )
3860         {
3861             if (this == SvRV(other))
3862                 RETPUSHYES;
3863             else
3864                 RETPUSHNO;
3865         }
3866
3867         ENTER;
3868         SAVETMPS;
3869         PUSHMARK(SP);
3870         PUSHs(other);
3871         PUTBACK;
3872         c = call_sv(this, G_SCALAR);
3873         SPAGAIN;
3874         if (c == 0)
3875             PUSHs(&PL_sv_no);
3876         else if (SvTEMP(TOPs))
3877             SvREFCNT_inc(TOPs);
3878         FREETMPS;
3879         LEAVE;
3880         RETURN;
3881     }
3882     else if (SM_REF(PVHV)) {
3883         if (SM_OTHER_REF(PVHV)) {
3884             /* Check that the key-sets are identical */
3885             HE *he;
3886             HV *other_hv = (HV *) SvRV(other);
3887             bool tied = FALSE;
3888             bool other_tied = FALSE;
3889             U32 this_key_count  = 0,
3890                 other_key_count = 0;
3891
3892             /* Tied hashes don't know how many keys they have. */
3893             if (SvTIED_mg(this, PERL_MAGIC_tied)) {
3894                 tied = TRUE;
3895             }
3896             else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3897                 HV * temp = other_hv;
3898                 other_hv = (HV *) this;
3899                 this  = (SV *) temp;
3900                 tied = TRUE;
3901             }
3902             if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3903                 other_tied = TRUE;
3904
3905             if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv))
3906                 RETPUSHNO;
3907
3908             /* The hashes have the same number of keys, so it suffices
3909                to check that one is a subset of the other. */
3910             (void) hv_iterinit((HV *) this);
3911             while ( (he = hv_iternext((HV *) this)) ) {
3912                 I32 key_len;
3913                 char *key = hv_iterkey(he, &key_len);
3914
3915                 ++ this_key_count;
3916
3917                 if(!hv_exists(other_hv, key, key_len)) {
3918                     (void) hv_iterinit((HV *) this);    /* reset iterator */
3919                     RETPUSHNO;
3920                 }
3921             }
3922
3923             if (other_tied) {
3924                 (void) hv_iterinit(other_hv);
3925                 while ( hv_iternext(other_hv) )
3926                     ++other_key_count;
3927             }
3928             else
3929                 other_key_count = HvUSEDKEYS(other_hv);
3930
3931             if (this_key_count != other_key_count)
3932                 RETPUSHNO;
3933             else
3934                 RETPUSHYES;
3935         }
3936         else if (SM_OTHER_REF(PVAV)) {
3937             AV *other_av = (AV *) SvRV(other);
3938             I32 other_len = av_len(other_av) + 1;
3939             I32 i;
3940
3941             if (HvUSEDKEYS((HV *) this) != other_len)
3942                 RETPUSHNO;
3943
3944             for(i = 0; i < other_len; ++i) {
3945                 SV **svp = av_fetch(other_av, i, FALSE);
3946                 char *key;
3947                 STRLEN key_len;
3948
3949                 if (!svp)       /* ??? When can this happen? */
3950                     RETPUSHNO;
3951
3952                 key = SvPV(*svp, key_len);
3953                 if(!hv_exists((HV *) this, key, key_len))
3954                     RETPUSHNO;
3955             }
3956             RETPUSHYES;
3957         }
3958         else if (SM_OTHER_REGEX) {
3959             PMOP *matcher = make_matcher(other_regex);
3960             HE *he;
3961
3962             (void) hv_iterinit((HV *) this);
3963             while ( (he = hv_iternext((HV *) this)) ) {
3964                 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
3965                     (void) hv_iterinit((HV *) this);
3966                     destroy_matcher(matcher);
3967                     RETPUSHYES;
3968                 }
3969             }
3970             destroy_matcher(matcher);
3971             RETPUSHNO;
3972         }
3973         else {
3974             if (hv_exists_ent((HV *) this, other, 0))
3975                 RETPUSHYES;
3976             else
3977                 RETPUSHNO;
3978         }
3979     }
3980     else if (SM_REF(PVAV)) {
3981         if (SM_OTHER_REF(PVAV)) {
3982             AV *other_av = (AV *) SvRV(other);
3983             if (av_len((AV *) this) != av_len(other_av))
3984                 RETPUSHNO;
3985             else {
3986                 I32 i;
3987                 I32 other_len = av_len(other_av);
3988
3989                 if (Nullhv == seen_this) {
3990                     seen_this = newHV();
3991                     (void) sv_2mortal((SV *) seen_this);
3992                 }
3993                 if (Nullhv == seen_other) {
3994                     seen_this = newHV();
3995                     (void) sv_2mortal((SV *) seen_other);
3996                 }
3997                 for(i = 0; i <= other_len; ++i) {
3998                     SV **this_elem = av_fetch((AV *)this, i, FALSE);
3999                     SV **other_elem = av_fetch(other_av, i, FALSE);
4000
4001                     if (!this_elem || !other_elem) {
4002                         if (this_elem || other_elem)
4003                             RETPUSHNO;
4004                     }
4005                     else if (SM_SEEN_THIS(*this_elem)
4006                          || SM_SEEN_OTHER(*other_elem))
4007                     {
4008                         if (*this_elem != *other_elem)
4009                             RETPUSHNO;
4010                     }
4011                     else {
4012                         hv_store_ent(seen_this,
4013                             sv_2mortal(newSViv(PTR2IV(*this_elem))),
4014                             &PL_sv_undef, 0);
4015                         hv_store_ent(seen_other,
4016                             sv_2mortal(newSViv(PTR2IV(*other_elem))),
4017                             &PL_sv_undef, 0);
4018                         PUSHs(*this_elem);
4019                         PUSHs(*other_elem);
4020
4021                         PUTBACK;
4022                         (void) do_smartmatch(seen_this, seen_other);
4023                         SPAGAIN;
4024
4025                         if (!SvTRUEx(POPs))
4026                             RETPUSHNO;
4027                     }
4028                 }
4029                 RETPUSHYES;
4030             }
4031         }
4032         else if (SM_OTHER_REGEX) {
4033             PMOP *matcher = make_matcher(other_regex);
4034             I32 i;
4035             I32 this_len = av_len((AV *) this);
4036
4037             for(i = 0; i <= this_len; ++i) {
4038                 SV ** svp = av_fetch((AV *)this, i, FALSE);
4039                 if (svp && matcher_matches_sv(matcher, *svp)) {
4040                     destroy_matcher(matcher);
4041                     RETPUSHYES;
4042                 }
4043             }
4044             destroy_matcher(matcher);
4045             RETPUSHNO;
4046         }
4047         else if (SvIOK(other) || SvNOK(other)) {
4048             I32 i;
4049
4050             for(i = 0; i <= AvFILL((AV *) this); ++i) {
4051                 SV ** svp = av_fetch((AV *)this, i, FALSE);
4052                 if (!svp)
4053                     continue;
4054
4055                 PUSHs(other);
4056                 PUSHs(*svp);
4057                 PUTBACK;
4058                 if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4059                     (void) pp_i_eq();
4060                 else
4061                     (void) pp_eq();
4062                 SPAGAIN;
4063                 if (SvTRUEx(POPs))
4064                     RETPUSHYES;
4065             }
4066             RETPUSHNO;
4067         }
4068         else if (SvPOK(other)) {
4069             I32 i;
4070             I32 this_len = av_len((AV *) this);
4071
4072             for(i = 0; i <= this_len; ++i) {
4073                 SV ** svp = av_fetch((AV *)this, i, FALSE);
4074                 if (!svp)
4075                     continue;
4076
4077                 PUSHs(other);
4078                 PUSHs(*svp);
4079                 PUTBACK;
4080                 (void) pp_seq();
4081                 SPAGAIN;
4082                 if (SvTRUEx(POPs))
4083                     RETPUSHYES;
4084             }
4085             RETPUSHNO;
4086         }
4087     }
4088     else if (!SvOK(d) || !SvOK(e)) {
4089         if (!SvOK(d) && !SvOK(e))
4090             RETPUSHYES;
4091         else
4092             RETPUSHNO;
4093     }
4094     else if (SM_REGEX) {
4095         PMOP *matcher = make_matcher(this_regex);
4096
4097         PUTBACK;
4098         PUSHs(matcher_matches_sv(matcher, other)
4099             ? &PL_sv_yes
4100             : &PL_sv_no);
4101         destroy_matcher(matcher);
4102         RETURN;
4103     }
4104     else if (SM_REF(PVCV)) {
4105         I32 c;
4106         /* This must be a null-prototyped sub, because we
4107            already checked for the other kind. */
4108
4109         ENTER;
4110         SAVETMPS;
4111         PUSHMARK(SP);
4112         PUTBACK;
4113         c = call_sv(this, G_SCALAR);
4114         SPAGAIN;
4115         if (c == 0)
4116             PUSHs(&PL_sv_undef);
4117         else if (SvTEMP(TOPs))
4118             SvREFCNT_inc(TOPs);
4119
4120         if (SM_OTHER_REF(PVCV)) {
4121             /* This one has to be null-proto'd too.
4122                Call both of 'em, and compare the results */
4123             PUSHMARK(SP);
4124             c = call_sv(SvRV(other), G_SCALAR);
4125             SPAGAIN;
4126             if (c == 0)
4127                 PUSHs(&PL_sv_undef);
4128             else if (SvTEMP(TOPs))
4129                 SvREFCNT_inc(TOPs);
4130             FREETMPS;
4131             LEAVE;
4132             PUTBACK;
4133             return pp_eq();
4134         }
4135
4136         FREETMPS;
4137         LEAVE;
4138         RETURN;
4139     }
4140     else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e))
4141          ||   ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) )
4142     {
4143         if (SvPOK(other) && !looks_like_number(other)) {
4144             /* String comparison */
4145             PUSHs(d); PUSHs(e);
4146             PUTBACK;
4147             return pp_seq();
4148         }
4149         /* Otherwise, numeric comparison */
4150         PUSHs(d); PUSHs(e);
4151         PUTBACK;
4152         if ((PL_curcop->op_private & HINT_INTEGER) == HINT_INTEGER)
4153             (void) pp_i_eq();
4154         else
4155             (void) pp_eq();
4156         SPAGAIN;
4157         if (SvTRUEx(POPs))
4158             RETPUSHYES;
4159         else
4160             RETPUSHNO;
4161     }
4162
4163     /* As a last resort, use string comparison */
4164     PUSHs(d); PUSHs(e);
4165     PUTBACK;
4166     return pp_seq();
4167 }
4168
4169 PP(pp_enterwhen)
4170 {
4171     dVAR; dSP;
4172     register PERL_CONTEXT *cx;
4173     const I32 gimme = GIMME_V;
4174
4175     /* This is essentially an optimization: if the match
4176        fails, we don't want to push a context and then
4177        pop it again right away, so we skip straight
4178        to the op that follows the leavewhen.
4179     */
4180     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4181         return cLOGOP->op_other->op_next;
4182
4183     ENTER;
4184     SAVETMPS;
4185
4186     PUSHBLOCK(cx, CXt_WHEN, SP);
4187     PUSHWHEN(cx);
4188
4189     RETURN;
4190 }
4191
4192 PP(pp_leavewhen)
4193 {
4194     dVAR; dSP;
4195     register PERL_CONTEXT *cx;
4196     I32 gimme;
4197     SV **newsp;
4198     PMOP *newpm;
4199
4200     POPBLOCK(cx,newpm);
4201     assert(CxTYPE(cx) == CXt_WHEN);
4202
4203     SP = newsp;
4204     PUTBACK;
4205
4206     PL_curpm = newpm;   /* pop $1 et al */
4207
4208     LEAVE;
4209     return NORMAL;
4210 }
4211
4212 PP(pp_continue)
4213 {
4214     dVAR;
4215     I32 cxix;
4216     register PERL_CONTEXT *cx;
4217     I32 inner;
4218
4219     cxix = dopoptowhen(cxstack_ix);
4220     if (cxix < 0)
4221         DIE(aTHX_ "Can't \"continue\" outside a when block");
4222     if (cxix < cxstack_ix)
4223         dounwind(cxix);
4224
4225     /* clear off anything above the scope we're re-entering */
4226     inner = PL_scopestack_ix;
4227     TOPBLOCK(cx);
4228     if (PL_scopestack_ix < inner)
4229         leave_scope(PL_scopestack[PL_scopestack_ix]);
4230     PL_curcop = cx->blk_oldcop;
4231     return cx->blk_givwhen.leave_op;
4232 }
4233
4234 PP(pp_break)
4235 {
4236     dVAR;
4237     I32 cxix;
4238     register PERL_CONTEXT *cx;
4239     I32 inner;
4240
4241     cxix = dopoptogiven(cxstack_ix);
4242     if (cxix < 0) {
4243         if (PL_op->op_flags & OPf_SPECIAL)
4244             DIE(aTHX_ "Can't use when() outside a topicalizer");
4245         else
4246             DIE(aTHX_ "Can't \"break\" outside a given block");
4247     }
4248     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4249         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4250
4251     if (cxix < cxstack_ix)
4252         dounwind(cxix);
4253
4254     /* clear off anything above the scope we're re-entering */
4255     inner = PL_scopestack_ix;
4256     TOPBLOCK(cx);
4257     if (PL_scopestack_ix < inner)
4258         leave_scope(PL_scopestack[PL_scopestack_ix]);
4259     PL_curcop = cx->blk_oldcop;
4260
4261     if (CxFOREACH(cx))
4262         return cx->blk_loop.next_op;
4263     else
4264         return cx->blk_givwhen.leave_op;
4265 }
4266
4267 STATIC OP *
4268 S_doparseform(pTHX_ SV *sv)
4269 {
4270     STRLEN len;
4271     register char *s = SvPV_force(sv, len);
4272     register char *send = s + len;
4273     register char *base = Nullch;
4274     register I32 skipspaces = 0;
4275     bool noblank   = FALSE;
4276     bool repeat    = FALSE;
4277     bool postspace = FALSE;
4278     U32 *fops;
4279     register U32 *fpc;
4280     U32 *linepc = 0;
4281     register I32 arg;
4282     bool ischop;
4283     bool unchopnum = FALSE;
4284     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4285
4286     if (len == 0)
4287         Perl_croak(aTHX_ "Null picture in formline");
4288
4289     /* estimate the buffer size needed */
4290     for (base = s; s <= send; s++) {
4291         if (*s == '\n' || *s == '@' || *s == '^')
4292             maxops += 10;
4293     }
4294     s = base;
4295     base = Nullch;
4296
4297     Newx(fops, maxops, U32);
4298     fpc = fops;
4299
4300     if (s < send) {
4301         linepc = fpc;
4302         *fpc++ = FF_LINEMARK;
4303         noblank = repeat = FALSE;
4304         base = s;
4305     }
4306
4307     while (s <= send) {
4308         switch (*s++) {
4309         default:
4310             skipspaces = 0;
4311             continue;
4312
4313         case '~':
4314             if (*s == '~') {
4315                 repeat = TRUE;
4316                 *s = ' ';
4317             }
4318             noblank = TRUE;
4319             s[-1] = ' ';
4320             /* FALL THROUGH */
4321         case ' ': case '\t':
4322             skipspaces++;
4323             continue;
4324         case 0:
4325             if (s < send) {
4326                 skipspaces = 0;
4327                 continue;
4328             } /* else FALL THROUGH */
4329         case '\n':
4330             arg = s - base;
4331             skipspaces++;
4332             arg -= skipspaces;
4333             if (arg) {
4334                 if (postspace)
4335                     *fpc++ = FF_SPACE;
4336                 *fpc++ = FF_LITERAL;
4337                 *fpc++ = (U16)arg;
4338             }
4339             postspace = FALSE;
4340             if (s <= send)
4341                 skipspaces--;
4342             if (skipspaces) {
4343                 *fpc++ = FF_SKIP;
4344                 *fpc++ = (U16)skipspaces;
4345             }
4346             skipspaces = 0;
4347             if (s <= send)
4348                 *fpc++ = FF_NEWLINE;
4349             if (noblank) {
4350                 *fpc++ = FF_BLANK;
4351                 if (repeat)
4352                     arg = fpc - linepc + 1;
4353                 else
4354                     arg = 0;
4355                 *fpc++ = (U16)arg;
4356             }
4357             if (s < send) {
4358                 linepc = fpc;
4359                 *fpc++ = FF_LINEMARK;
4360                 noblank = repeat = FALSE;
4361                 base = s;
4362             }
4363             else
4364                 s++;
4365             continue;
4366
4367         case '@':
4368         case '^':
4369             ischop = s[-1] == '^';
4370
4371             if (postspace) {
4372                 *fpc++ = FF_SPACE;
4373                 postspace = FALSE;
4374             }
4375             arg = (s - base) - 1;
4376             if (arg) {
4377                 *fpc++ = FF_LITERAL;
4378                 *fpc++ = (U16)arg;
4379             }
4380
4381             base = s - 1;
4382             *fpc++ = FF_FETCH;
4383             if (*s == '*') {
4384                 s++;
4385                 *fpc++ = 2;  /* skip the @* or ^* */
4386                 if (ischop) {
4387                     *fpc++ = FF_LINESNGL;
4388                     *fpc++ = FF_CHOP;
4389                 } else
4390                     *fpc++ = FF_LINEGLOB;
4391             }
4392             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4393                 arg = ischop ? 512 : 0;
4394                 base = s - 1;
4395                 while (*s == '#')
4396                     s++;
4397                 if (*s == '.') {
4398                     const char * const f = ++s;
4399                     while (*s == '#')
4400                         s++;
4401                     arg |= 256 + (s - f);
4402                 }
4403                 *fpc++ = s - base;              /* fieldsize for FETCH */
4404                 *fpc++ = FF_DECIMAL;
4405                 *fpc++ = (U16)arg;
4406                 unchopnum |= ! ischop;
4407             }
4408             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4409                 arg = ischop ? 512 : 0;
4410                 base = s - 1;
4411                 s++;                                /* skip the '0' first */
4412                 while (*s == '#')
4413                     s++;
4414                 if (*s == '.') {
4415                     const char * const f = ++s;
4416                     while (*s == '#')
4417                         s++;
4418                     arg |= 256 + (s - f);
4419                 }
4420                 *fpc++ = s - base;                /* fieldsize for FETCH */
4421                 *fpc++ = FF_0DECIMAL;
4422                 *fpc++ = (U16)arg;
4423                 unchopnum |= ! ischop;
4424             }
4425             else {
4426                 I32 prespace = 0;
4427                 bool ismore = FALSE;
4428
4429                 if (*s == '>') {
4430                     while (*++s == '>') ;
4431                     prespace = FF_SPACE;
4432                 }
4433                 else if (*s == '|') {
4434                     while (*++s == '|') ;
4435                     prespace = FF_HALFSPACE;
4436                     postspace = TRUE;
4437                 }
4438                 else {
4439                     if (*s == '<')
4440                         while (*++s == '<') ;
4441                     postspace = TRUE;
4442                 }
4443                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4444                     s += 3;
4445                     ismore = TRUE;
4446                 }
4447                 *fpc++ = s - base;              /* fieldsize for FETCH */
4448
4449                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4450
4451                 if (prespace)
4452                     *fpc++ = (U16)prespace;
4453                 *fpc++ = FF_ITEM;
4454                 if (ismore)
4455                     *fpc++ = FF_MORE;
4456                 if (ischop)
4457                     *fpc++ = FF_CHOP;
4458             }
4459             base = s;
4460             skipspaces = 0;
4461             continue;
4462         }
4463     }
4464     *fpc++ = FF_END;
4465
4466     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4467     arg = fpc - fops;
4468     { /* need to jump to the next word */
4469         int z;
4470         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4471         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4472         s = SvPVX(sv) + SvCUR(sv) + z;
4473     }
4474     Copy(fops, s, arg, U32);
4475     Safefree(fops);
4476     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
4477     SvCOMPILED_on(sv);
4478
4479     if (unchopnum && repeat)
4480         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4481     return 0;
4482 }
4483
4484
4485 STATIC bool
4486 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4487 {
4488     /* Can value be printed in fldsize chars, using %*.*f ? */
4489     NV pwr = 1;
4490     NV eps = 0.5;
4491     bool res = FALSE;
4492     int intsize = fldsize - (value < 0 ? 1 : 0);
4493
4494     if (frcsize & 256)
4495         intsize--;
4496     frcsize &= 255;
4497     intsize -= frcsize;
4498
4499     while (intsize--) pwr *= 10.0;
4500     while (frcsize--) eps /= 10.0;
4501
4502     if( value >= 0 ){
4503         if (value + eps >= pwr)
4504             res = TRUE;
4505     } else {
4506         if (value - eps <= -pwr)
4507             res = TRUE;
4508     }
4509     return res;
4510 }
4511
4512 static I32
4513 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4514 {
4515     dVAR;
4516     SV * const datasv = FILTER_DATA(idx);
4517     const int filter_has_file = IoLINES(datasv);
4518     GV * const filter_child_proc = (GV *)IoFMT_GV(datasv);
4519     SV * const filter_state = (SV *)IoTOP_GV(datasv);
4520     SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4521     int len = 0;
4522
4523     /* I was having segfault trouble under Linux 2.2.5 after a
4524        parse error occured.  (Had to hack around it with a test
4525        for PL_error_count == 0.)  Solaris doesn't segfault --
4526        not sure where the trouble is yet.  XXX */
4527
4528     if (filter_has_file) {
4529         len = FILTER_READ(idx+1, buf_sv, maxlen);
4530     }
4531
4532     if (filter_sub && len >= 0) {
4533         dSP;
4534         int count;
4535
4536         ENTER;
4537         SAVE_DEFSV;
4538         SAVETMPS;
4539         EXTEND(SP, 2);
4540
4541         DEFSV = buf_sv;
4542         PUSHMARK(SP);
4543         PUSHs(sv_2mortal(newSViv(maxlen)));
4544         if (filter_state) {
4545             PUSHs(filter_state);
4546         }
4547         PUTBACK;
4548         count = call_sv(filter_sub, G_SCALAR);
4549         SPAGAIN;
4550
4551         if (count > 0) {
4552             SV *out = POPs;
4553             if (SvOK(out)) {
4554                 len = SvIV(out);
4555             }
4556         }
4557
4558         PUTBACK;
4559         FREETMPS;
4560         LEAVE;
4561     }
4562
4563     if (len <= 0) {
4564         IoLINES(datasv) = 0;
4565         if (filter_child_proc) {
4566             SvREFCNT_dec(filter_child_proc);
4567             IoFMT_GV(datasv) = Nullgv;
4568         }
4569         if (filter_state) {
4570             SvREFCNT_dec(filter_state);
4571             IoTOP_GV(datasv) = Nullgv;
4572         }
4573         if (filter_sub) {
4574             SvREFCNT_dec(filter_sub);
4575             IoBOTTOM_GV(datasv) = Nullgv;
4576         }
4577         filter_del(S_run_user_filter);
4578     }
4579
4580     return len;
4581 }
4582
4583 /* perhaps someone can come up with a better name for
4584    this?  it is not really "absolute", per se ... */
4585 static bool
4586 S_path_is_absolute(pTHX_ const char *name)
4587 {
4588     if (PERL_FILE_IS_ABSOLUTE(name)
4589 #ifdef MACOS_TRADITIONAL
4590         || (*name == ':')
4591 #else
4592         || (*name == '.' && (name[1] == '/' ||
4593                              (name[1] == '.' && name[2] == '/')))
4594 #endif
4595          )
4596     {
4597         return TRUE;
4598     }
4599     else
4600         return FALSE;
4601 }
4602
4603 /*
4604  * Local variables:
4605  * c-indentation-style: bsd
4606  * c-basic-offset: 4
4607  * indent-tabs-mode: t
4608  * End:
4609  *
4610  * ex: set ts=8 sts=4 sw=4 noet:
4611  */