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