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         len = SvCUR(sv);
2750     }
2751     else
2752         len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code,
2753                          (unsigned long)++PL_evalseq);
2754     SAVECOPFILE_FREE(&PL_compiling);
2755     CopFILE_set(&PL_compiling, tmpbuf+2);
2756     SAVECOPLINE(&PL_compiling);
2757     CopLINE_set(&PL_compiling, 1);
2758     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2759        deleting the eval's FILEGV from the stash before gv_check() runs
2760        (i.e. before run-time proper). To work around the coredump that
2761        ensues, we always turn GvMULTI_on for any globals that were
2762        introduced within evals. See force_ident(). GSAR 96-10-12 */
2763     safestr = savepvn(tmpbuf, len);
2764     SAVEDELETE(PL_defstash, safestr, len);
2765     SAVEHINTS();
2766 #ifdef OP_IN_REGISTER
2767     PL_opsave = op;
2768 #else
2769     SAVEVPTR(PL_op);
2770 #endif
2771
2772     /* we get here either during compilation, or via pp_regcomp at runtime */
2773     runtime = IN_PERL_RUNTIME;
2774     if (runtime)
2775         runcv = find_runcv(NULL);
2776
2777     PL_op = &dummy;
2778     PL_op->op_type = OP_ENTEREVAL;
2779     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2780     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2781     PUSHEVAL(cx, 0, Nullgv);
2782
2783     if (runtime)
2784         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2785     else
2786         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2787     POPBLOCK(cx,PL_curpm);
2788     POPEVAL(cx);
2789
2790     (*startop)->op_type = OP_NULL;
2791     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2792     lex_end();
2793     /* XXX DAPM do this properly one year */
2794     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2795     LEAVE;
2796     if (IN_PERL_COMPILETIME)
2797         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2798 #ifdef OP_IN_REGISTER
2799     op = PL_opsave;
2800 #endif
2801     PERL_UNUSED_VAR(newsp);
2802     PERL_UNUSED_VAR(optype);
2803
2804     return rop;
2805 }
2806
2807
2808 /*
2809 =for apidoc find_runcv
2810
2811 Locate the CV corresponding to the currently executing sub or eval.
2812 If db_seqp is non_null, skip CVs that are in the DB package and populate
2813 *db_seqp with the cop sequence number at the point that the DB:: code was
2814 entered. (allows debuggers to eval in the scope of the breakpoint rather
2815 than in the scope of the debugger itself).
2816
2817 =cut
2818 */
2819
2820 CV*
2821 Perl_find_runcv(pTHX_ U32 *db_seqp)
2822 {
2823     PERL_SI      *si;
2824
2825     if (db_seqp)
2826         *db_seqp = PL_curcop->cop_seq;
2827     for (si = PL_curstackinfo; si; si = si->si_prev) {
2828         I32 ix;
2829         for (ix = si->si_cxix; ix >= 0; ix--) {
2830             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2831             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2832                 CV * const cv = cx->blk_sub.cv;
2833                 /* skip DB:: code */
2834                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2835                     *db_seqp = cx->blk_oldcop->cop_seq;
2836                     continue;
2837                 }
2838                 return cv;
2839             }
2840             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2841                 return PL_compcv;
2842         }
2843     }
2844     return PL_main_cv;
2845 }
2846
2847
2848 /* Compile a require/do, an eval '', or a /(?{...})/.
2849  * In the last case, startop is non-null, and contains the address of
2850  * a pointer that should be set to the just-compiled code.
2851  * outside is the lexically enclosing CV (if any) that invoked us.
2852  */
2853
2854 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2855 STATIC OP *
2856 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2857 {
2858     dVAR; dSP;
2859     OP * const saveop = PL_op;
2860
2861     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2862                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2863                   : EVAL_INEVAL);
2864
2865     PUSHMARK(SP);
2866
2867     SAVESPTR(PL_compcv);
2868     PL_compcv = (CV*)NEWSV(1104,0);
2869     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2870     CvEVAL_on(PL_compcv);
2871     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2872     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2873
2874     CvOUTSIDE_SEQ(PL_compcv) = seq;
2875     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2876
2877     /* set up a scratch pad */
2878
2879     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2880
2881
2882     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2883
2884     /* make sure we compile in the right package */
2885
2886     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2887         SAVESPTR(PL_curstash);
2888         PL_curstash = CopSTASH(PL_curcop);
2889     }
2890     SAVESPTR(PL_beginav);
2891     PL_beginav = newAV();
2892     SAVEFREESV(PL_beginav);
2893     SAVEI32(PL_error_count);
2894
2895     /* try to compile it */
2896
2897     PL_eval_root = Nullop;
2898     PL_error_count = 0;
2899     PL_curcop = &PL_compiling;
2900     PL_curcop->cop_arybase = 0;
2901     if (saveop && saveop->op_flags & OPf_SPECIAL)
2902         PL_in_eval |= EVAL_KEEPERR;
2903     else
2904         sv_setpvn(ERRSV,"",0);
2905     if (yyparse() || PL_error_count || !PL_eval_root) {
2906         SV **newsp;                     /* Used by POPBLOCK. */
2907         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2908         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2909         const char *msg;
2910
2911         PL_op = saveop;
2912         if (PL_eval_root) {
2913             op_free(PL_eval_root);
2914             PL_eval_root = Nullop;
2915         }
2916         SP = PL_stack_base + POPMARK;           /* pop original mark */
2917         if (!startop) {
2918             POPBLOCK(cx,PL_curpm);
2919             POPEVAL(cx);
2920         }
2921         lex_end();
2922         LEAVE;
2923
2924         msg = SvPVx_nolen_const(ERRSV);
2925         if (optype == OP_REQUIRE) {
2926             const SV * const nsv = cx->blk_eval.old_namesv;
2927             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2928                           &PL_sv_undef, 0);
2929             DIE(aTHX_ "%sCompilation failed in require",
2930                 *msg ? msg : "Unknown error\n");
2931         }
2932         else if (startop) {
2933             POPBLOCK(cx,PL_curpm);
2934             POPEVAL(cx);
2935             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2936                        (*msg ? msg : "Unknown error\n"));
2937         }
2938         else {
2939             if (!*msg) {
2940                 sv_setpv(ERRSV, "Compilation error");
2941             }
2942         }
2943         PERL_UNUSED_VAR(newsp);
2944         RETPUSHUNDEF;
2945     }
2946     CopLINE_set(&PL_compiling, 0);
2947     if (startop) {
2948         *startop = PL_eval_root;
2949     } else
2950         SAVEFREEOP(PL_eval_root);
2951
2952     /* Set the context for this new optree.
2953      * If the last op is an OP_REQUIRE, force scalar context.
2954      * Otherwise, propagate the context from the eval(). */
2955     if (PL_eval_root->op_type == OP_LEAVEEVAL
2956             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2957             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2958             == OP_REQUIRE)
2959         scalar(PL_eval_root);
2960     else if (gimme & G_VOID)
2961         scalarvoid(PL_eval_root);
2962     else if (gimme & G_ARRAY)
2963         list(PL_eval_root);
2964     else
2965         scalar(PL_eval_root);
2966
2967     DEBUG_x(dump_eval());
2968
2969     /* Register with debugger: */
2970     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2971         CV * const cv = get_cv("DB::postponed", FALSE);
2972         if (cv) {
2973             dSP;
2974             PUSHMARK(SP);
2975             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2976             PUTBACK;
2977             call_sv((SV*)cv, G_DISCARD);
2978         }
2979     }
2980
2981     /* compiled okay, so do it */
2982
2983     CvDEPTH(PL_compcv) = 1;
2984     SP = PL_stack_base + POPMARK;               /* pop original mark */
2985     PL_op = saveop;                     /* The caller may need it. */
2986     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2987
2988     RETURNOP(PL_eval_start);
2989 }
2990
2991 STATIC PerlIO *
2992 S_doopen_pm(pTHX_ const char *name, const char *mode)
2993 {
2994 #ifndef PERL_DISABLE_PMC
2995     const STRLEN namelen = strlen(name);
2996     PerlIO *fp;
2997
2998     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2999         SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3000         const char * const pmc = SvPV_nolen_const(pmcsv);
3001         Stat_t pmcstat;
3002         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3003             fp = PerlIO_open(name, mode);
3004         }
3005         else {
3006             Stat_t pmstat;
3007             if (PerlLIO_stat(name, &pmstat) < 0 ||
3008                 pmstat.st_mtime < pmcstat.st_mtime)
3009             {
3010                 fp = PerlIO_open(pmc, mode);
3011             }
3012             else {
3013                 fp = PerlIO_open(name, mode);
3014             }
3015         }
3016         SvREFCNT_dec(pmcsv);
3017     }
3018     else {
3019         fp = PerlIO_open(name, mode);
3020     }
3021     return fp;
3022 #else
3023     return PerlIO_open(name, mode);
3024 #endif /* !PERL_DISABLE_PMC */
3025 }
3026
3027 PP(pp_require)
3028 {
3029     dVAR; dSP;
3030     register PERL_CONTEXT *cx;
3031     SV *sv;
3032     const char *name;
3033     STRLEN len;
3034     const char *tryname = Nullch;
3035     SV *namesv = Nullsv;
3036     const I32 gimme = GIMME_V;
3037     PerlIO *tryrsfp = 0;
3038     int filter_has_file = 0;
3039     GV *filter_child_proc = 0;
3040     SV *filter_state = 0;
3041     SV *filter_sub = 0;
3042     SV *hook_sv = 0;
3043     SV *encoding;
3044     OP *op;
3045
3046     sv = POPs;
3047     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3048         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )       /* require v5.6.1 */
3049                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3050                         "v-string in use/require non-portable");
3051
3052         sv = new_version(sv);
3053         if (!sv_derived_from(PL_patchlevel, "version"))
3054             (void *)upg_version(PL_patchlevel);
3055         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3056             if ( vcmp(sv,PL_patchlevel) < 0 )
3057                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3058                     vnormal(sv), vnormal(PL_patchlevel));
3059         }
3060         else {
3061             if ( vcmp(sv,PL_patchlevel) > 0 )
3062                 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3063                     vnormal(sv), vnormal(PL_patchlevel));
3064         }
3065
3066             RETPUSHYES;
3067     }
3068     name = SvPV_const(sv, len);
3069     if (!(name && len > 0 && *name))
3070         DIE(aTHX_ "Null filename used");
3071     TAINT_PROPER("require");
3072     if (PL_op->op_type == OP_REQUIRE) {
3073         SV ** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3074         if ( svp ) {
3075             if (*svp != &PL_sv_undef)
3076                 RETPUSHYES;
3077             else
3078                 DIE(aTHX_ "Compilation failed in require");
3079         }
3080     }
3081
3082     /* prepare to compile file */
3083
3084     if (path_is_absolute(name)) {
3085         tryname = name;
3086         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3087     }
3088 #ifdef MACOS_TRADITIONAL
3089     if (!tryrsfp) {
3090         char newname[256];
3091
3092         MacPerl_CanonDir(name, newname, 1);
3093         if (path_is_absolute(newname)) {
3094             tryname = newname;
3095             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3096         }
3097     }
3098 #endif
3099     if (!tryrsfp) {
3100         AV * const ar = GvAVn(PL_incgv);
3101         I32 i;
3102 #ifdef VMS
3103         char *unixname;
3104         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3105 #endif
3106         {
3107             namesv = NEWSV(806, 0);
3108             for (i = 0; i <= AvFILL(ar); i++) {
3109                 SV *dirsv = *av_fetch(ar, i, TRUE);
3110
3111                 if (SvROK(dirsv)) {
3112                     int count;
3113                     SV *loader = dirsv;
3114
3115                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3116                         && !sv_isobject(loader))
3117                     {
3118                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3119                     }
3120
3121                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3122                                    PTR2UV(SvRV(dirsv)), name);
3123                     tryname = SvPVX_const(namesv);
3124                     tryrsfp = 0;
3125
3126                     ENTER;
3127                     SAVETMPS;
3128                     EXTEND(SP, 2);
3129
3130                     PUSHMARK(SP);
3131                     PUSHs(dirsv);
3132                     PUSHs(sv);
3133                     PUTBACK;
3134                     if (sv_isobject(loader))
3135                         count = call_method("INC", G_ARRAY);
3136                     else
3137                         count = call_sv(loader, G_ARRAY);
3138                     SPAGAIN;
3139
3140                     if (count > 0) {
3141                         int i = 0;
3142                         SV *arg;
3143
3144                         SP -= count - 1;
3145                         arg = SP[i++];
3146
3147                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3148                             arg = SvRV(arg);
3149                         }
3150
3151                         if (SvTYPE(arg) == SVt_PVGV) {
3152                             IO *io = GvIO((GV *)arg);
3153
3154                             ++filter_has_file;
3155
3156                             if (io) {
3157                                 tryrsfp = IoIFP(io);
3158                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3159                                     /* reading from a child process doesn't
3160                                        nest -- when returning from reading
3161                                        the inner module, the outer one is
3162                                        unreadable (closed?)  I've tried to
3163                                        save the gv to manage the lifespan of
3164                                        the pipe, but this didn't help. XXX */
3165                                     filter_child_proc = (GV *)arg;
3166                                     (void)SvREFCNT_inc(filter_child_proc);
3167                                 }
3168                                 else {
3169                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3170                                         PerlIO_close(IoOFP(io));
3171                                     }
3172                                     IoIFP(io) = Nullfp;
3173                                     IoOFP(io) = Nullfp;
3174                                 }
3175                             }
3176
3177                             if (i < count) {
3178                                 arg = SP[i++];
3179                             }
3180                         }
3181
3182                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3183                             filter_sub = arg;
3184                             (void)SvREFCNT_inc(filter_sub);
3185
3186                             if (i < count) {
3187                                 filter_state = SP[i];
3188                                 (void)SvREFCNT_inc(filter_state);
3189                             }
3190
3191                             if (tryrsfp == 0) {
3192                                 tryrsfp = PerlIO_open("/dev/null",
3193                                                       PERL_SCRIPT_MODE);
3194                             }
3195                         }
3196                         SP--;
3197                     }
3198
3199                     PUTBACK;
3200                     FREETMPS;
3201                     LEAVE;
3202
3203                     if (tryrsfp) {
3204                         hook_sv = dirsv;
3205                         break;
3206                     }
3207
3208                     filter_has_file = 0;
3209                     if (filter_child_proc) {
3210                         SvREFCNT_dec(filter_child_proc);
3211                         filter_child_proc = 0;
3212                     }
3213                     if (filter_state) {
3214                         SvREFCNT_dec(filter_state);
3215                         filter_state = 0;
3216                     }
3217                     if (filter_sub) {
3218                         SvREFCNT_dec(filter_sub);
3219                         filter_sub = 0;
3220                     }
3221                 }
3222                 else {
3223                   if (!path_is_absolute(name)
3224 #ifdef MACOS_TRADITIONAL
3225                         /* We consider paths of the form :a:b ambiguous and interpret them first
3226                            as global then as local
3227                         */
3228                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3229 #endif
3230                   ) {
3231                     const char *dir = SvPVx_nolen_const(dirsv);
3232 #ifdef MACOS_TRADITIONAL
3233                     char buf1[256];
3234                     char buf2[256];
3235
3236                     MacPerl_CanonDir(name, buf2, 1);
3237                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3238 #else
3239 #  ifdef VMS
3240                     char *unixdir;
3241                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3242                         continue;
3243                     sv_setpv(namesv, unixdir);
3244                     sv_catpv(namesv, unixname);
3245 #  else
3246 #    ifdef __SYMBIAN32__
3247                     if (PL_origfilename[0] &&
3248                         PL_origfilename[1] == ':' &&
3249                         !(dir[0] && dir[1] == ':'))
3250                         Perl_sv_setpvf(aTHX_ namesv,
3251                                        "%c:%s\\%s",
3252                                        PL_origfilename[0],
3253                                        dir, name);
3254                     else
3255                         Perl_sv_setpvf(aTHX_ namesv,
3256                                        "%s\\%s",
3257                                        dir, name);
3258 #    else
3259                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3260 #    endif
3261 #  endif
3262 #endif
3263                     TAINT_PROPER("require");
3264                     tryname = SvPVX_const(namesv);
3265                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3266                     if (tryrsfp) {
3267                         if (tryname[0] == '.' && tryname[1] == '/')
3268                             tryname += 2;
3269                         break;
3270                     }
3271                   }
3272                 }
3273             }
3274         }
3275     }
3276     SAVECOPFILE_FREE(&PL_compiling);
3277     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3278     SvREFCNT_dec(namesv);
3279     if (!tryrsfp) {
3280         if (PL_op->op_type == OP_REQUIRE) {
3281             const char *msgstr = name;
3282             if(errno == EMFILE) {
3283                 SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3284                 sv_catpv(msg, ":  ");
3285                 sv_catpv(msg, Strerror(errno));
3286                 msgstr = SvPV_nolen_const(msg);
3287             } else {
3288                 if (namesv) {                   /* did we lookup @INC? */
3289                     SV * const msg = sv_2mortal(newSVpv(msgstr,0));
3290                     SV * const dirmsgsv = NEWSV(0, 0);
3291                     AV * const ar = GvAVn(PL_incgv);
3292                     I32 i;
3293                     sv_catpvn(msg, " in @INC", 8);
3294                     if (instr(SvPVX_const(msg), ".h "))
3295                         sv_catpv(msg, " (change .h to .ph maybe?)");
3296                     if (instr(SvPVX_const(msg), ".ph "))
3297                         sv_catpv(msg, " (did you run h2ph?)");
3298                     sv_catpv(msg, " (@INC contains:");
3299                     for (i = 0; i <= AvFILL(ar); i++) {
3300                         const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3301                         Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3302                         sv_catsv(msg, dirmsgsv);
3303                     }
3304                     sv_catpvn(msg, ")", 1);
3305                     SvREFCNT_dec(dirmsgsv);
3306                     msgstr = SvPV_nolen_const(msg);
3307                 }
3308             }
3309             DIE(aTHX_ "Can't locate %s", msgstr);
3310         }
3311
3312         RETPUSHUNDEF;
3313     }
3314     else
3315         SETERRNO(0, SS_NORMAL);
3316
3317     /* Assume success here to prevent recursive requirement. */
3318     /* name is never assigned to again, so len is still strlen(name)  */
3319     /* Check whether a hook in @INC has already filled %INC */
3320     if (!hook_sv) {
3321         (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3322     } else {
3323         SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3324         if (!svp)
3325             (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc(hook_sv), 0 );
3326     }
3327
3328     ENTER;
3329     SAVETMPS;
3330     lex_start(sv_2mortal(newSVpvn("",0)));
3331     SAVEGENERICSV(PL_rsfp_filters);
3332     PL_rsfp_filters = Nullav;
3333
3334     PL_rsfp = tryrsfp;
3335     SAVEHINTS();
3336     PL_hints = 0;
3337     SAVESPTR(PL_compiling.cop_warnings);
3338     if (PL_dowarn & G_WARN_ALL_ON)
3339         PL_compiling.cop_warnings = pWARN_ALL ;
3340     else if (PL_dowarn & G_WARN_ALL_OFF)
3341         PL_compiling.cop_warnings = pWARN_NONE ;
3342     else if (PL_taint_warn)
3343         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3344     else
3345         PL_compiling.cop_warnings = pWARN_STD ;
3346     SAVESPTR(PL_compiling.cop_io);
3347     PL_compiling.cop_io = Nullsv;
3348
3349     if (filter_sub || filter_child_proc) {
3350         SV * const datasv = filter_add(run_user_filter, Nullsv);
3351         IoLINES(datasv) = filter_has_file;
3352         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3353         IoTOP_GV(datasv) = (GV *)filter_state;
3354         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3355     }
3356
3357     /* switch to eval mode */
3358     PUSHBLOCK(cx, CXt_EVAL, SP);
3359     PUSHEVAL(cx, name, Nullgv);
3360     cx->blk_eval.retop = PL_op->op_next;
3361
3362     SAVECOPLINE(&PL_compiling);
3363     CopLINE_set(&PL_compiling, 0);
3364
3365     PUTBACK;
3366
3367     /* Store and reset encoding. */
3368     encoding = PL_encoding;
3369     PL_encoding = Nullsv;
3370
3371     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3372
3373     /* Restore encoding. */
3374     PL_encoding = encoding;
3375
3376     return op;
3377 }
3378
3379 PP(pp_entereval)
3380 {
3381     dVAR; dSP;
3382     register PERL_CONTEXT *cx;
3383     dPOPss;
3384     const I32 gimme = GIMME_V;
3385     const I32 was = PL_sub_generation;
3386     char tbuf[TYPE_DIGITS(long) + 12];
3387     char *tmpbuf = tbuf;
3388     char *safestr;
3389     STRLEN len;
3390     OP *ret;
3391     CV* runcv;
3392     U32 seq;
3393
3394     if (!SvPV_nolen_const(sv))
3395         RETPUSHUNDEF;
3396     TAINT_PROPER("eval");
3397
3398     ENTER;
3399     lex_start(sv);
3400     SAVETMPS;
3401
3402     /* switch to eval mode */
3403
3404     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3405         SV * const sv = sv_newmortal();
3406         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3407                        (unsigned long)++PL_evalseq,
3408                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3409         tmpbuf = SvPVX(sv);
3410         len = SvCUR(sv);
3411     }
3412     else
3413         len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3414     SAVECOPFILE_FREE(&PL_compiling);
3415     CopFILE_set(&PL_compiling, tmpbuf+2);
3416     SAVECOPLINE(&PL_compiling);
3417     CopLINE_set(&PL_compiling, 1);
3418     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3419        deleting the eval's FILEGV from the stash before gv_check() runs
3420        (i.e. before run-time proper). To work around the coredump that
3421        ensues, we always turn GvMULTI_on for any globals that were
3422        introduced within evals. See force_ident(). GSAR 96-10-12 */
3423     safestr = savepvn(tmpbuf, len);
3424     SAVEDELETE(PL_defstash, safestr, len);
3425     SAVEHINTS();
3426     PL_hints = PL_op->op_targ;
3427     SAVESPTR(PL_compiling.cop_warnings);
3428     if (specialWARN(PL_curcop->cop_warnings))
3429         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3430     else {
3431         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3432         SAVEFREESV(PL_compiling.cop_warnings);
3433     }
3434     SAVESPTR(PL_compiling.cop_io);
3435     if (specialCopIO(PL_curcop->cop_io))
3436         PL_compiling.cop_io = PL_curcop->cop_io;
3437     else {
3438         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3439         SAVEFREESV(PL_compiling.cop_io);
3440     }
3441     /* special case: an eval '' executed within the DB package gets lexically
3442      * placed in the first non-DB CV rather than the current CV - this
3443      * allows the debugger to execute code, find lexicals etc, in the
3444      * scope of the code being debugged. Passing &seq gets find_runcv
3445      * to do the dirty work for us */
3446     runcv = find_runcv(&seq);
3447
3448     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3449     PUSHEVAL(cx, 0, Nullgv);
3450     cx->blk_eval.retop = PL_op->op_next;
3451
3452     /* prepare to compile string */
3453
3454     if (PERLDB_LINE && PL_curstash != PL_debstash)
3455         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3456     PUTBACK;
3457     ret = doeval(gimme, NULL, runcv, seq);
3458     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3459         && ret != PL_op->op_next) {     /* Successive compilation. */
3460         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3461     }
3462     return DOCATCH(ret);
3463 }
3464
3465 PP(pp_leaveeval)
3466 {
3467     dVAR; dSP;
3468     register SV **mark;
3469     SV **newsp;
3470     PMOP *newpm;
3471     I32 gimme;
3472     register PERL_CONTEXT *cx;
3473     OP *retop;
3474     const U8 save_flags = PL_op -> op_flags;
3475     I32 optype;
3476
3477     POPBLOCK(cx,newpm);
3478     POPEVAL(cx);
3479     retop = cx->blk_eval.retop;
3480
3481     TAINT_NOT;
3482     if (gimme == G_VOID)
3483         MARK = newsp;
3484     else if (gimme == G_SCALAR) {
3485         MARK = newsp + 1;
3486         if (MARK <= SP) {
3487             if (SvFLAGS(TOPs) & SVs_TEMP)
3488                 *MARK = TOPs;
3489             else
3490                 *MARK = sv_mortalcopy(TOPs);
3491         }
3492         else {
3493             MEXTEND(mark,0);
3494             *MARK = &PL_sv_undef;
3495         }
3496         SP = MARK;
3497     }
3498     else {
3499         /* in case LEAVE wipes old return values */
3500         for (mark = newsp + 1; mark <= SP; mark++) {
3501             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3502                 *mark = sv_mortalcopy(*mark);
3503                 TAINT_NOT;      /* Each item is independent */
3504             }
3505         }
3506     }
3507     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3508
3509 #ifdef DEBUGGING
3510     assert(CvDEPTH(PL_compcv) == 1);
3511 #endif
3512     CvDEPTH(PL_compcv) = 0;
3513     lex_end();
3514
3515     if (optype == OP_REQUIRE &&
3516         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3517     {
3518         /* Unassume the success we assumed earlier. */
3519         SV * const nsv = cx->blk_eval.old_namesv;
3520         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3521         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3522         /* die_where() did LEAVE, or we won't be here */
3523     }
3524     else {
3525         LEAVE;
3526         if (!(save_flags & OPf_SPECIAL))
3527             sv_setpvn(ERRSV,"",0);
3528     }
3529
3530     RETURNOP(retop);
3531 }
3532
3533 PP(pp_entertry)
3534 {
3535     dVAR; dSP;
3536     register PERL_CONTEXT *cx;
3537     const I32 gimme = GIMME_V;
3538
3539     ENTER;
3540     SAVETMPS;
3541
3542     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3543     PUSHEVAL(cx, 0, 0);
3544     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3545
3546     PL_in_eval = EVAL_INEVAL;
3547     sv_setpvn(ERRSV,"",0);
3548     PUTBACK;
3549     return DOCATCH(PL_op->op_next);
3550 }
3551
3552 PP(pp_leavetry)
3553 {
3554     dVAR; dSP;
3555     register SV **mark;
3556     SV **newsp;
3557     PMOP *newpm;
3558     I32 gimme;
3559     register PERL_CONTEXT *cx;
3560     I32 optype;
3561
3562     POPBLOCK(cx,newpm);
3563     POPEVAL(cx);
3564     PERL_UNUSED_VAR(optype);
3565
3566     TAINT_NOT;
3567     if (gimme == G_VOID)
3568         SP = newsp;
3569     else if (gimme == G_SCALAR) {
3570         MARK = newsp + 1;
3571         if (MARK <= SP) {
3572             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3573                 *MARK = TOPs;
3574             else
3575                 *MARK = sv_mortalcopy(TOPs);
3576         }
3577         else {
3578             MEXTEND(mark,0);
3579             *MARK = &PL_sv_undef;
3580         }
3581         SP = MARK;
3582     }
3583     else {
3584         /* in case LEAVE wipes old return values */
3585         for (mark = newsp + 1; mark <= SP; mark++) {
3586             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3587                 *mark = sv_mortalcopy(*mark);
3588                 TAINT_NOT;      /* Each item is independent */
3589             }
3590         }
3591     }
3592     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3593
3594     LEAVE;
3595     sv_setpvn(ERRSV,"",0);
3596     RETURN;
3597 }
3598
3599 STATIC OP *
3600 S_doparseform(pTHX_ SV *sv)
3601 {
3602     STRLEN len;
3603     register char *s = SvPV_force(sv, len);
3604     register char *send = s + len;
3605     register char *base = Nullch;
3606     register I32 skipspaces = 0;
3607     bool noblank   = FALSE;
3608     bool repeat    = FALSE;
3609     bool postspace = FALSE;
3610     U32 *fops;
3611     register U32 *fpc;
3612     U32 *linepc = 0;
3613     register I32 arg;
3614     bool ischop;
3615     bool unchopnum = FALSE;
3616     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3617
3618     if (len == 0)
3619         Perl_croak(aTHX_ "Null picture in formline");
3620
3621     /* estimate the buffer size needed */
3622     for (base = s; s <= send; s++) {
3623         if (*s == '\n' || *s == '@' || *s == '^')
3624             maxops += 10;
3625     }
3626     s = base;
3627     base = Nullch;
3628
3629     Newx(fops, maxops, U32);
3630     fpc = fops;
3631
3632     if (s < send) {
3633         linepc = fpc;
3634         *fpc++ = FF_LINEMARK;
3635         noblank = repeat = FALSE;
3636         base = s;
3637     }
3638
3639     while (s <= send) {
3640         switch (*s++) {
3641         default:
3642             skipspaces = 0;
3643             continue;
3644
3645         case '~':
3646             if (*s == '~') {
3647                 repeat = TRUE;
3648                 *s = ' ';
3649             }
3650             noblank = TRUE;
3651             s[-1] = ' ';
3652             /* FALL THROUGH */
3653         case ' ': case '\t':
3654             skipspaces++;
3655             continue;
3656         case 0:
3657             if (s < send) {
3658                 skipspaces = 0;
3659                 continue;
3660             } /* else FALL THROUGH */
3661         case '\n':
3662             arg = s - base;
3663             skipspaces++;
3664             arg -= skipspaces;
3665             if (arg) {
3666                 if (postspace)
3667                     *fpc++ = FF_SPACE;
3668                 *fpc++ = FF_LITERAL;
3669                 *fpc++ = (U16)arg;
3670             }
3671             postspace = FALSE;
3672             if (s <= send)
3673                 skipspaces--;
3674             if (skipspaces) {
3675                 *fpc++ = FF_SKIP;
3676                 *fpc++ = (U16)skipspaces;
3677             }
3678             skipspaces = 0;
3679             if (s <= send)
3680                 *fpc++ = FF_NEWLINE;
3681             if (noblank) {
3682                 *fpc++ = FF_BLANK;
3683                 if (repeat)
3684                     arg = fpc - linepc + 1;
3685                 else
3686                     arg = 0;
3687                 *fpc++ = (U16)arg;
3688             }
3689             if (s < send) {
3690                 linepc = fpc;
3691                 *fpc++ = FF_LINEMARK;
3692                 noblank = repeat = FALSE;
3693                 base = s;
3694             }
3695             else
3696                 s++;
3697             continue;
3698
3699         case '@':
3700         case '^':
3701             ischop = s[-1] == '^';
3702
3703             if (postspace) {
3704                 *fpc++ = FF_SPACE;
3705                 postspace = FALSE;
3706             }
3707             arg = (s - base) - 1;
3708             if (arg) {
3709                 *fpc++ = FF_LITERAL;
3710                 *fpc++ = (U16)arg;
3711             }
3712
3713             base = s - 1;
3714             *fpc++ = FF_FETCH;
3715             if (*s == '*') {
3716                 s++;
3717                 *fpc++ = 2;  /* skip the @* or ^* */
3718                 if (ischop) {
3719                     *fpc++ = FF_LINESNGL;
3720                     *fpc++ = FF_CHOP;
3721                 } else
3722                     *fpc++ = FF_LINEGLOB;
3723             }
3724             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3725                 arg = ischop ? 512 : 0;
3726                 base = s - 1;
3727                 while (*s == '#')
3728                     s++;
3729                 if (*s == '.') {
3730                     const char * const f = ++s;
3731                     while (*s == '#')
3732                         s++;
3733                     arg |= 256 + (s - f);
3734                 }
3735                 *fpc++ = s - base;              /* fieldsize for FETCH */
3736                 *fpc++ = FF_DECIMAL;
3737                 *fpc++ = (U16)arg;
3738                 unchopnum |= ! ischop;
3739             }
3740             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3741                 arg = ischop ? 512 : 0;
3742                 base = s - 1;
3743                 s++;                                /* skip the '0' first */
3744                 while (*s == '#')
3745                     s++;
3746                 if (*s == '.') {
3747                     const char * const f = ++s;
3748                     while (*s == '#')
3749                         s++;
3750                     arg |= 256 + (s - f);
3751                 }
3752                 *fpc++ = s - base;                /* fieldsize for FETCH */
3753                 *fpc++ = FF_0DECIMAL;
3754                 *fpc++ = (U16)arg;
3755                 unchopnum |= ! ischop;
3756             }
3757             else {
3758                 I32 prespace = 0;
3759                 bool ismore = FALSE;
3760
3761                 if (*s == '>') {
3762                     while (*++s == '>') ;
3763                     prespace = FF_SPACE;
3764                 }
3765                 else if (*s == '|') {
3766                     while (*++s == '|') ;
3767                     prespace = FF_HALFSPACE;
3768                     postspace = TRUE;
3769                 }
3770                 else {
3771                     if (*s == '<')
3772                         while (*++s == '<') ;
3773                     postspace = TRUE;
3774                 }
3775                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3776                     s += 3;
3777                     ismore = TRUE;
3778                 }
3779                 *fpc++ = s - base;              /* fieldsize for FETCH */
3780
3781                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3782
3783                 if (prespace)
3784                     *fpc++ = (U16)prespace;
3785                 *fpc++ = FF_ITEM;
3786                 if (ismore)
3787                     *fpc++ = FF_MORE;
3788                 if (ischop)
3789                     *fpc++ = FF_CHOP;
3790             }
3791             base = s;
3792             skipspaces = 0;
3793             continue;
3794         }
3795     }
3796     *fpc++ = FF_END;
3797
3798     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3799     arg = fpc - fops;
3800     { /* need to jump to the next word */
3801         int z;
3802         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3803         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3804         s = SvPVX(sv) + SvCUR(sv) + z;
3805     }
3806     Copy(fops, s, arg, U32);
3807     Safefree(fops);
3808     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3809     SvCOMPILED_on(sv);
3810
3811     if (unchopnum && repeat)
3812         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3813     return 0;
3814 }
3815
3816
3817 STATIC bool
3818 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3819 {
3820     /* Can value be printed in fldsize chars, using %*.*f ? */
3821     NV pwr = 1;
3822     NV eps = 0.5;
3823     bool res = FALSE;
3824     int intsize = fldsize - (value < 0 ? 1 : 0);
3825
3826     if (frcsize & 256)
3827         intsize--;
3828     frcsize &= 255;
3829     intsize -= frcsize;
3830
3831     while (intsize--) pwr *= 10.0;
3832     while (frcsize--) eps /= 10.0;
3833
3834     if( value >= 0 ){
3835         if (value + eps >= pwr)
3836             res = TRUE;
3837     } else {
3838         if (value - eps <= -pwr)
3839             res = TRUE;
3840     }
3841     return res;
3842 }
3843
3844 static I32
3845 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3846 {
3847     dVAR;
3848     SV *datasv = FILTER_DATA(idx);
3849     const int filter_has_file = IoLINES(datasv);
3850     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3851     SV *filter_state = (SV *)IoTOP_GV(datasv);
3852     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3853     int len = 0;
3854
3855     /* I was having segfault trouble under Linux 2.2.5 after a
3856        parse error occured.  (Had to hack around it with a test
3857        for PL_error_count == 0.)  Solaris doesn't segfault --
3858        not sure where the trouble is yet.  XXX */
3859
3860     if (filter_has_file) {
3861         len = FILTER_READ(idx+1, buf_sv, maxlen);
3862     }
3863
3864     if (filter_sub && len >= 0) {
3865         dSP;
3866         int count;
3867
3868         ENTER;
3869         SAVE_DEFSV;
3870         SAVETMPS;
3871         EXTEND(SP, 2);
3872
3873         DEFSV = buf_sv;
3874         PUSHMARK(SP);
3875         PUSHs(sv_2mortal(newSViv(maxlen)));
3876         if (filter_state) {
3877             PUSHs(filter_state);
3878         }
3879         PUTBACK;
3880         count = call_sv(filter_sub, G_SCALAR);
3881         SPAGAIN;
3882
3883         if (count > 0) {
3884             SV *out = POPs;
3885             if (SvOK(out)) {
3886                 len = SvIV(out);
3887             }
3888         }
3889
3890         PUTBACK;
3891         FREETMPS;
3892         LEAVE;
3893     }
3894
3895     if (len <= 0) {
3896         IoLINES(datasv) = 0;
3897         if (filter_child_proc) {
3898             SvREFCNT_dec(filter_child_proc);
3899             IoFMT_GV(datasv) = Nullgv;
3900         }
3901         if (filter_state) {
3902             SvREFCNT_dec(filter_state);
3903             IoTOP_GV(datasv) = Nullgv;
3904         }
3905         if (filter_sub) {
3906             SvREFCNT_dec(filter_sub);
3907             IoBOTTOM_GV(datasv) = Nullgv;
3908         }
3909         filter_del(run_user_filter);
3910     }
3911
3912     return len;
3913 }
3914
3915 /* perhaps someone can come up with a better name for
3916    this?  it is not really "absolute", per se ... */
3917 static bool
3918 S_path_is_absolute(pTHX_ const char *name)
3919 {
3920     if (PERL_FILE_IS_ABSOLUTE(name)
3921 #ifdef MACOS_TRADITIONAL
3922         || (*name == ':'))
3923 #else
3924         || (*name == '.' && (name[1] == '/' ||
3925                              (name[1] == '.' && name[2] == '/'))))
3926 #endif
3927     {
3928         return TRUE;
3929     }
3930     else
3931         return FALSE;
3932 }
3933
3934 /*
3935  * Local variables:
3936  * c-indentation-style: bsd
3937  * c-basic-offset: 4
3938  * indent-tabs-mode: t
3939  * End:
3940  *
3941  * ex: set ts=8 sts=4 sw=4 noet:
3942  */