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