pp_ctl.c

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