pp_ctl.c

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