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