pp_ctl.c

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