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((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(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 = (const char *)
 800                 ((arg & 256) ?
 801                  "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
 802 #else
 803             fmt = (const char *)
 804                 ((arg & 256) ?
 805                  "%#0*.*f"              : "%0*.*f");
 806 #endif
 807             goto ff_dec;
 808         case FF_DECIMAL:
 809             arg = *fpc++;
 810 #if defined(USE_LONG_DOUBLE)
 811             fmt = (const char *)
 812                 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
 813 #else
 814             fmt = (const char *)
 815                 ((arg & 256) ? "%#*.*f"              : "%*.*f");
 816 #endif
 817         ff_dec:
 818             /* If the field is marked with ^ and the value is undefined,
 819                blank it out. */
 820             if ((arg & 512) && !SvOK(sv)) {
 821                 arg = fieldsize;
 822                 while (arg--)
 823                     *t++ = ' ';
 824                 break;
 825             }
 826             gotsome = TRUE;
 827             value = SvNV(sv);
 828             /* overflow evidence */
 829             if (num_overflow(value, fieldsize, arg)) {
 830                 arg = fieldsize;
 831                 while (arg--)
 832                     *t++ = '#';
 833                 break;
 834             }
 835             /* Formats aren't yet marked for locales, so assume "yes". */
 836             {
 837                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 838                 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
 839                 RESTORE_NUMERIC_STANDARD();
 840             }
 841             t += fieldsize;
 842             break;
 843
 844         case FF_NEWLINE:
 845             f++;
 846             while (t-- > linemark && *t == ' ') ;
 847             t++;
 848             *t++ = '\n';
 849             break;
 850
 851         case FF_BLANK:
 852             arg = *fpc++;
 853             if (gotsome) {
 854                 if (arg) {              /* repeat until fields exhausted? */
 855                     *t = '\0';
 856                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 857                     lines += FmLINES(PL_formtarget);
 858                     if (lines == 200) {
 859                         arg = t - linemark;
 860                         if (strnEQ(linemark, linemark - arg, arg))
 861                             DIE(aTHX_ "Runaway format");
 862                     }
 863                     if (targ_is_utf8)
 864                         SvUTF8_on(PL_formtarget);
 865                     FmLINES(PL_formtarget) = lines;
 866                     SP = ORIGMARK;
 867                     RETURNOP(cLISTOP->op_first);
 868                 }
 869             }
 870             else {
 871                 t = linemark;
 872                 lines--;
 873             }
 874             break;
 875
 876         case FF_MORE:
 877             {
 878                 const char *s = chophere;
 879                 const char *send = item + len;
 880                 if (chopspace) {
 881                     while (isSPACE(*s) && (s < send))
 882                         s++;
 883                 }
 884                 if (s < send) {
 885                     char *s1;
 886                     arg = fieldsize - itemsize;
 887                     if (arg) {
 888                         fieldsize -= arg;
 889                         while (arg-- > 0)
 890                             *t++ = ' ';
 891                     }
 892                     s1 = t - 3;
 893                     if (strnEQ(s1,"   ",3)) {
 894                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
 895                             s1--;
 896                     }
 897                     *s1++ = '.';
 898                     *s1++ = '.';
 899                     *s1++ = '.';
 900                 }
 901                 break;
 902             }
 903         case FF_END:
 904             *t = '\0';
 905             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 906             if (targ_is_utf8)
 907                 SvUTF8_on(PL_formtarget);
 908             FmLINES(PL_formtarget) += lines;
 909             SP = ORIGMARK;
 910             RETPUSHYES;
 911         }
 912     }
 913 }
 914
 915 PP(pp_grepstart)
 916 {
 917     dVAR; dSP;
 918     SV *src;
 919
 920     if (PL_stack_base + *PL_markstack_ptr == SP) {
 921         (void)POPMARK;
 922         if (GIMME_V == G_SCALAR)
 923             XPUSHs(sv_2mortal(newSViv(0)));
 924         RETURNOP(PL_op->op_next->op_next);
 925     }
 926     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
 927     pp_pushmark();                              /* push dst */
 928     pp_pushmark();                              /* push src */
 929     ENTER;                                      /* enter outer scope */
 930
 931     SAVETMPS;
 932     if (PL_op->op_private & OPpGREP_LEX)
 933         SAVESPTR(PAD_SVl(PL_op->op_targ));
 934     else
 935         SAVE_DEFSV;
 936     ENTER;                                      /* enter inner scope */
 937     SAVEVPTR(PL_curpm);
 938
 939     src = PL_stack_base[*PL_markstack_ptr];
 940     SvTEMP_off(src);
 941     if (PL_op->op_private & OPpGREP_LEX)
 942         PAD_SVl(PL_op->op_targ) = src;
 943     else
 944         DEFSV = src;
 945
 946     PUTBACK;
 947     if (PL_op->op_type == OP_MAPSTART)
 948         pp_pushmark();                  /* push top */
 949     return ((LOGOP*)PL_op->op_next)->op_other;
 950 }
 951
 952 PP(pp_mapwhile)
 953 {
 954     dVAR; dSP;
 955     const I32 gimme = GIMME_V;
 956     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
 957     I32 count;
 958     I32 shift;
 959     SV** src;
 960     SV** dst;
 961
 962     /* first, move source pointer to the next item in the source list */
 963     ++PL_markstack_ptr[-1];
 964
 965     /* if there are new items, push them into the destination list */
 966     if (items && gimme != G_VOID) {
 967         /* might need to make room back there first */
 968         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
 969             /* XXX this implementation is very pessimal because the stack
 970              * is repeatedly extended for every set of items.  Is possible
 971              * to do this without any stack extension or copying at all
 972              * by maintaining a separate list over which the map iterates
 973              * (like foreach does). --gsar */
 974
 975             /* everything in the stack after the destination list moves
 976              * towards the end the stack by the amount of room needed */
 977             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
 978
 979             /* items to shift up (accounting for the moved source pointer) */
 980             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
 981
 982             /* This optimization is by Ben Tilly and it does
 983              * things differently from what Sarathy (gsar)
 984              * is describing.  The downside of this optimization is
 985              * that leaves "holes" (uninitialized and hopefully unused areas)
 986              * to the Perl stack, but on the other hand this
 987              * shouldn't be a problem.  If Sarathy's idea gets
 988              * implemented, this optimization should become
 989              * irrelevant.  --jhi */
 990             if (shift < count)
 991                 shift = count; /* Avoid shifting too often --Ben Tilly */
 992
 993             EXTEND(SP,shift);
 994             src = SP;
 995             dst = (SP += shift);
 996             PL_markstack_ptr[-1] += shift;
 997             *PL_markstack_ptr += shift;
 998             while (count--)
 999                 *dst-- = *src--;
1000         }
1001         /* copy the new items down to the destination list */
1002         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1003         if (gimme == G_ARRAY) {
1004             while (items-- > 0)
1005                 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1006         }
1007         else {
1008             /* scalar context: we don't care about which values map returns
1009              * (we use undef here). And so we certainly don't want to do mortal
1010              * copies of meaningless values. */
1011             while (items-- > 0) {
1012                 (void)POPs;
1013                 *dst-- = &PL_sv_undef;
1014             }
1015         }
1016     }
1017     LEAVE;                                      /* exit inner scope */
1018
1019     /* All done yet? */
1020     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1021
1022         (void)POPMARK;                          /* pop top */
1023         LEAVE;                                  /* exit outer scope */
1024         (void)POPMARK;                          /* pop src */
1025         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1026         (void)POPMARK;                          /* pop dst */
1027         SP = PL_stack_base + POPMARK;           /* pop original mark */
1028         if (gimme == G_SCALAR) {
1029             if (PL_op->op_private & OPpGREP_LEX) {
1030                 SV* sv = sv_newmortal();
1031                 sv_setiv(sv, items);
1032                 PUSHs(sv);
1033             }
1034             else {
1035                 dTARGET;
1036                 XPUSHi(items);
1037             }
1038         }
1039         else if (gimme == G_ARRAY)
1040             SP += items;
1041         RETURN;
1042     }
1043     else {
1044         SV *src;
1045
1046         ENTER;                                  /* enter inner scope */
1047         SAVEVPTR(PL_curpm);
1048
1049         /* set $_ to the new source item */
1050         src = PL_stack_base[PL_markstack_ptr[-1]];
1051         SvTEMP_off(src);
1052         if (PL_op->op_private & OPpGREP_LEX)
1053             PAD_SVl(PL_op->op_targ) = src;
1054         else
1055             DEFSV = src;
1056
1057         RETURNOP(cLOGOP->op_other);
1058     }
1059 }
1060
1061 /* Range stuff. */
1062
1063 PP(pp_range)
1064 {
1065     dVAR;
1066     if (GIMME == G_ARRAY)
1067         return NORMAL;
1068     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1069         return cLOGOP->op_other;
1070     else
1071         return NORMAL;
1072 }
1073
1074 PP(pp_flip)
1075 {
1076     dVAR;
1077     dSP;
1078
1079     if (GIMME == G_ARRAY) {
1080         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1081     }
1082     else {
1083         dTOPss;
1084         SV * const targ = PAD_SV(PL_op->op_targ);
1085         int flip = 0;
1086
1087         if (PL_op->op_private & OPpFLIP_LINENUM) {
1088             if (GvIO(PL_last_in_gv)) {
1089                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1090             }
1091             else {
1092                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1093                 if (gv && GvSV(gv))
1094                     flip = SvIV(sv) == SvIV(GvSV(gv));
1095             }
1096         } else {
1097             flip = SvTRUE(sv);
1098         }
1099         if (flip) {
1100             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1101             if (PL_op->op_flags & OPf_SPECIAL) {
1102                 sv_setiv(targ, 1);
1103                 SETs(targ);
1104                 RETURN;
1105             }
1106             else {
1107                 sv_setiv(targ, 0);
1108                 SP--;
1109                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1110             }
1111         }
1112         sv_setpvn(TARG, "", 0);
1113         SETs(targ);
1114         RETURN;
1115     }
1116 }
1117
1118 /* This code tries to decide if "$left .. $right" should use the
1119    magical string increment, or if the range is numeric (we make
1120    an exception for .."0" [#18165]). AMS 20021031. */
1121
1122 #define RANGE_IS_NUMERIC(left,right) ( \
1123         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1124         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1125         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1126           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1127          && (!SvOK(right) || looks_like_number(right))))
1128
1129 PP(pp_flop)
1130 {
1131     dVAR; dSP;
1132
1133     if (GIMME == G_ARRAY) {
1134         dPOPPOPssrl;
1135
1136         SvGETMAGIC(left);
1137         SvGETMAGIC(right);
1138
1139         if (RANGE_IS_NUMERIC(left,right)) {
1140             register IV i, j;
1141             IV max;
1142             if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1143                 (SvOK(right) && SvNV(right) > IV_MAX))
1144                 DIE(aTHX_ "Range iterator outside integer range");
1145             i = SvIV(left);
1146             max = SvIV(right);
1147             if (max >= i) {
1148                 j = max - i + 1;
1149                 EXTEND_MORTAL(j);
1150                 EXTEND(SP, j);
1151             }
1152             else
1153                 j = 0;
1154             while (j--) {
1155                 SV * const sv = sv_2mortal(newSViv(i++));
1156                 PUSHs(sv);
1157             }
1158         }
1159         else {
1160             SV * const final = sv_mortalcopy(right);
1161             STRLEN len;
1162             const char * const tmps = SvPV_const(final, len);
1163
1164             SV *sv = sv_mortalcopy(left);
1165             SvPV_force_nolen(sv);
1166             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1167                 XPUSHs(sv);
1168                 if (strEQ(SvPVX_const(sv),tmps))
1169                     break;
1170                 sv = sv_2mortal(newSVsv(sv));
1171                 sv_inc(sv);
1172             }
1173         }
1174     }
1175     else {
1176         dTOPss;
1177         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1178         int flop = 0;
1179         sv_inc(targ);
1180
1181         if (PL_op->op_private & OPpFLIP_LINENUM) {
1182             if (GvIO(PL_last_in_gv)) {
1183                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1184             }
1185             else {
1186                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1187                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1188             }
1189         }
1190         else {
1191             flop = SvTRUE(sv);
1192         }
1193
1194         if (flop) {
1195             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1196             sv_catpvs(targ, "E0");
1197         }
1198         SETs(targ);
1199     }
1200
1201     RETURN;
1202 }
1203
1204 /* Control. */
1205
1206 static const char * const context_name[] = {
1207     "pseudo-block",
1208     "subroutine",
1209     "eval",
1210     "loop",
1211     "substitution",
1212     "block",
1213     "format",
1214     "given",
1215     "when"
1216 };
1217
1218 STATIC I32
1219 S_dopoptolabel(pTHX_ const char *label)
1220 {
1221     dVAR;
1222     register I32 i;
1223
1224     for (i = cxstack_ix; i >= 0; i--) {
1225         register const PERL_CONTEXT * const cx = &cxstack[i];
1226         switch (CxTYPE(cx)) {
1227         case CXt_SUBST:
1228         case CXt_SUB:
1229         case CXt_FORMAT:
1230         case CXt_EVAL:
1231         case CXt_NULL:
1232         case CXt_GIVEN:
1233         case CXt_WHEN:
1234             if (ckWARN(WARN_EXITING))
1235                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1236                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1237             if (CxTYPE(cx) == CXt_NULL)
1238                 return -1;
1239             break;
1240         case CXt_LOOP:
1241             if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1242                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1243                         (long)i, cx->blk_loop.label));
1244                 continue;
1245             }
1246             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1247             return i;
1248         }
1249     }
1250     return i;
1251 }
1252
1253
1254
1255 I32
1256 Perl_dowantarray(pTHX)
1257 {
1258     dVAR;
1259     const I32 gimme = block_gimme();
1260     return (gimme == G_VOID) ? G_SCALAR : gimme;
1261 }
1262
1263 I32
1264 Perl_block_gimme(pTHX)
1265 {
1266     dVAR;
1267     const I32 cxix = dopoptosub(cxstack_ix);
1268     if (cxix < 0)
1269         return G_VOID;
1270
1271     switch (cxstack[cxix].blk_gimme) {
1272     case G_VOID:
1273         return G_VOID;
1274     case G_SCALAR:
1275         return G_SCALAR;
1276     case G_ARRAY:
1277         return G_ARRAY;
1278     default:
1279         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1280         /* NOTREACHED */
1281         return 0;
1282     }
1283 }
1284
1285 I32
1286 Perl_is_lvalue_sub(pTHX)
1287 {
1288     dVAR;
1289     const I32 cxix = dopoptosub(cxstack_ix);
1290     assert(cxix >= 0);  /* We should only be called from inside subs */
1291
1292     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1293         return cxstack[cxix].blk_sub.lval;
1294     else
1295         return 0;
1296 }
1297
1298 STATIC I32
1299 S_dopoptosub(pTHX_ I32 startingblock)
1300 {
1301     dVAR;
1302     return dopoptosub_at(cxstack, startingblock);
1303 }
1304
1305 STATIC I32
1306 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1307 {
1308     dVAR;
1309     I32 i;
1310     for (i = startingblock; i >= 0; i--) {
1311         register const PERL_CONTEXT * const cx = &cxstk[i];
1312         switch (CxTYPE(cx)) {
1313         default:
1314             continue;
1315         case CXt_EVAL:
1316         case CXt_SUB:
1317         case CXt_FORMAT:
1318             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1319             return i;
1320         }
1321     }
1322     return i;
1323 }
1324
1325 STATIC I32
1326 S_dopoptoeval(pTHX_ I32 startingblock)
1327 {
1328     dVAR;
1329     I32 i;
1330     for (i = startingblock; i >= 0; i--) {
1331         register const PERL_CONTEXT *cx = &cxstack[i];
1332         switch (CxTYPE(cx)) {
1333         default:
1334             continue;
1335         case CXt_EVAL:
1336             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1337             return i;
1338         }
1339     }
1340     return i;
1341 }
1342
1343 STATIC I32
1344 S_dopoptoloop(pTHX_ I32 startingblock)
1345 {
1346     dVAR;
1347     I32 i;
1348     for (i = startingblock; i >= 0; i--) {
1349         register const PERL_CONTEXT * const cx = &cxstack[i];
1350         switch (CxTYPE(cx)) {
1351         case CXt_SUBST:
1352         case CXt_SUB:
1353         case CXt_FORMAT:
1354         case CXt_EVAL:
1355         case CXt_NULL:
1356             if (ckWARN(WARN_EXITING))
1357                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1358                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1359             if ((CxTYPE(cx)) == CXt_NULL)
1360                 return -1;
1361             break;
1362         case CXt_LOOP:
1363             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1364             return i;
1365         }
1366     }
1367     return i;
1368 }
1369
1370 STATIC I32
1371 S_dopoptogiven(pTHX_ I32 startingblock)
1372 {
1373     dVAR;
1374     I32 i;
1375     for (i = startingblock; i >= 0; i--) {
1376         register const PERL_CONTEXT *cx = &cxstack[i];
1377         switch (CxTYPE(cx)) {
1378         default:
1379             continue;
1380         case CXt_GIVEN:
1381             DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1382             return i;
1383         case CXt_LOOP:
1384             if (CxFOREACHDEF(cx)) {
1385                 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1386                 return i;
1387             }
1388         }
1389     }
1390     return i;
1391 }
1392
1393 STATIC I32
1394 S_dopoptowhen(pTHX_ I32 startingblock)
1395 {
1396     dVAR;
1397     I32 i;
1398     for (i = startingblock; i >= 0; i--) {
1399         register const PERL_CONTEXT *cx = &cxstack[i];
1400         switch (CxTYPE(cx)) {
1401         default:
1402             continue;
1403         case CXt_WHEN:
1404             DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1405             return i;
1406         }
1407     }
1408     return i;
1409 }
1410
1411 void
1412 Perl_dounwind(pTHX_ I32 cxix)
1413 {
1414     dVAR;
1415     I32 optype;
1416
1417     while (cxstack_ix > cxix) {
1418         SV *sv;
1419         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1420         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1421                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1422         /* Note: we don't need to restore the base context info till the end. */
1423         switch (CxTYPE(cx)) {
1424         case CXt_SUBST:
1425             POPSUBST(cx);
1426             continue;  /* not break */
1427         case CXt_SUB:
1428             POPSUB(cx,sv);
1429             LEAVESUB(sv);
1430             break;
1431         case CXt_EVAL:
1432             POPEVAL(cx);
1433             break;
1434         case CXt_LOOP:
1435             POPLOOP(cx);
1436             break;
1437         case CXt_NULL:
1438             break;
1439         case CXt_FORMAT:
1440             POPFORMAT(cx);
1441             break;
1442         }
1443         cxstack_ix--;
1444     }
1445     PERL_UNUSED_VAR(optype);
1446 }
1447
1448 void
1449 Perl_qerror(pTHX_ SV *err)
1450 {
1451     dVAR;
1452     if (PL_in_eval)
1453         sv_catsv(ERRSV, err);
1454     else if (PL_errors)
1455         sv_catsv(PL_errors, err);
1456     else
1457         Perl_warn(aTHX_ "%"SVf, (void*)err);
1458     ++PL_error_count;
1459 }
1460
1461 OP *
1462 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1463 {
1464     dVAR;
1465
1466     if (PL_in_eval) {
1467         I32 cxix;
1468         I32 gimme;
1469
1470         if (message) {
1471             if (PL_in_eval & EVAL_KEEPERR) {
1472                 static const char prefix[] = "\t(in cleanup) ";
1473                 SV * const err = ERRSV;
1474                 const char *e = NULL;
1475                 if (!SvPOK(err))
1476                     sv_setpvn(err,"",0);
1477                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1478                     STRLEN len;
1479                     e = SvPV_const(err, len);
1480                     e += len - msglen;
1481                     if (*e != *message || strNE(e,message))
1482                         e = NULL;
1483                 }
1484                 if (!e) {
1485                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1486                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1487                     sv_catpvn(err, message, msglen);
1488                     if (ckWARN(WARN_MISC)) {
1489                         const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1490                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1491                     }
1492                 }
1493             }
1494             else {
1495                 sv_setpvn(ERRSV, message, msglen);
1496             }
1497         }
1498
1499         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1500                && PL_curstackinfo->si_prev)
1501         {
1502             dounwind(-1);
1503             POPSTACK;
1504         }
1505
1506         if (cxix >= 0) {
1507             I32 optype;
1508             register PERL_CONTEXT *cx;
1509             SV **newsp;
1510
1511             if (cxix < cxstack_ix)
1512                 dounwind(cxix);
1513
1514             POPBLOCK(cx,PL_curpm);
1515             if (CxTYPE(cx) != CXt_EVAL) {
1516                 if (!message)
1517                     message = SvPVx_const(ERRSV, msglen);
1518                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1519                 PerlIO_write(Perl_error_log, message, msglen);
1520                 my_exit(1);
1521             }
1522             POPEVAL(cx);
1523
1524             if (gimme == G_SCALAR)
1525                 *++newsp = &PL_sv_undef;
1526             PL_stack_sp = newsp;
1527
1528             LEAVE;
1529
1530             /* LEAVE could clobber PL_curcop (see save_re_context())
1531              * XXX it might be better to find a way to avoid messing with
1532              * PL_curcop in save_re_context() instead, but this is a more
1533              * minimal fix --GSAR */
1534             PL_curcop = cx->blk_oldcop;
1535
1536             if (optype == OP_REQUIRE) {
1537                 const char* const msg = SvPVx_nolen_const(ERRSV);
1538                 SV * const nsv = cx->blk_eval.old_namesv;
1539                 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1540                                &PL_sv_undef, 0);
1541                 DIE(aTHX_ "%sCompilation failed in require",
1542                     *msg ? msg : "Unknown error\n");
1543             }
1544             assert(CxTYPE(cx) == CXt_EVAL);
1545             return cx->blk_eval.retop;
1546         }
1547     }
1548     if (!message)
1549         message = SvPVx_const(ERRSV, msglen);
1550
1551     write_to_stderr(message, msglen);
1552     my_failure_exit();
1553     /* NOTREACHED */
1554     return 0;
1555 }
1556
1557 PP(pp_xor)
1558 {
1559     dVAR; dSP; dPOPTOPssrl;
1560     if (SvTRUE(left) != SvTRUE(right))
1561         RETSETYES;
1562     else
1563         RETSETNO;
1564 }
1565
1566 PP(pp_caller)
1567 {
1568     dVAR;
1569     dSP;
1570     register I32 cxix = dopoptosub(cxstack_ix);
1571     register const PERL_CONTEXT *cx;
1572     register const PERL_CONTEXT *ccstack = cxstack;
1573     const PERL_SI *top_si = PL_curstackinfo;
1574     I32 gimme;
1575     const char *stashname;
1576     I32 count = 0;
1577
1578     if (MAXARG)
1579         count = POPi;
1580
1581     for (;;) {
1582         /* we may be in a higher stacklevel, so dig down deeper */
1583         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1584             top_si = top_si->si_prev;
1585             ccstack = top_si->si_cxstack;
1586             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1587         }
1588         if (cxix < 0) {
1589             if (GIMME != G_ARRAY) {
1590                 EXTEND(SP, 1);
1591                 RETPUSHUNDEF;
1592             }
1593             RETURN;
1594         }
1595         /* caller() should not report the automatic calls to &DB::sub */
1596         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1597                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1598             count++;
1599         if (!count--)
1600             break;
1601         cxix = dopoptosub_at(ccstack, cxix - 1);
1602     }
1603
1604     cx = &ccstack[cxix];
1605     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1606         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1607         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1608            field below is defined for any cx. */
1609         /* caller() should not report the automatic calls to &DB::sub */
1610         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1611             cx = &ccstack[dbcxix];
1612     }
1613
1614     stashname = CopSTASHPV(cx->blk_oldcop);
1615     if (GIMME != G_ARRAY) {
1616         EXTEND(SP, 1);
1617         if (!stashname)
1618             PUSHs(&PL_sv_undef);
1619         else {
1620             dTARGET;
1621             sv_setpv(TARG, stashname);
1622             PUSHs(TARG);
1623         }
1624         RETURN;
1625     }
1626
1627     EXTEND(SP, 11);
1628
1629     if (!stashname)
1630         PUSHs(&PL_sv_undef);
1631     else
1632         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1633     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1634     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1635     if (!MAXARG)
1636         RETURN;
1637     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1638         GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1639         /* So is ccstack[dbcxix]. */
1640         if (isGV(cvgv)) {
1641             SV * const sv = newSV(0);
1642             gv_efullname3(sv, cvgv, NULL);
1643             PUSHs(sv_2mortal(sv));
1644             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1645         }
1646         else {
1647             PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1648             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1649         }
1650     }
1651     else {
1652         PUSHs(sv_2mortal(newSVpvs("(eval)")));
1653         PUSHs(sv_2mortal(newSViv(0)));
1654     }
1655     gimme = (I32)cx->blk_gimme;
1656     if (gimme == G_VOID)
1657         PUSHs(&PL_sv_undef);
1658     else
1659         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1660     if (CxTYPE(cx) == CXt_EVAL) {
1661         /* eval STRING */
1662         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1663             PUSHs(cx->blk_eval.cur_text);
1664             PUSHs(&PL_sv_no);
1665         }
1666         /* require */
1667         else if (cx->blk_eval.old_namesv) {
1668             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1669             PUSHs(&PL_sv_yes);
1670         }
1671         /* eval BLOCK (try blocks have old_namesv == 0) */
1672         else {
1673             PUSHs(&PL_sv_undef);
1674             PUSHs(&PL_sv_undef);
1675         }
1676     }
1677     else {
1678         PUSHs(&PL_sv_undef);
1679         PUSHs(&PL_sv_undef);
1680     }
1681     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1682         && CopSTASH_eq(PL_curcop, PL_debstash))
1683     {
1684         AV * const ary = cx->blk_sub.argarray;
1685         const int off = AvARRAY(ary) - AvALLOC(ary);
1686
1687         if (!PL_dbargs) {
1688             GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1689             PL_dbargs = GvAV(gv_AVadd(tmpgv));
1690             GvMULTI_on(tmpgv);
1691             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1692         }
1693
1694         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1695             av_extend(PL_dbargs, AvFILLp(ary) + off);
1696         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1697         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1698     }
1699     /* XXX only hints propagated via op_private are currently
1700      * visible (others are not easily accessible, since they
1701      * use the global PL_hints) */
1702     PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
1703     {
1704         SV * mask ;
1705         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1706
1707         if  (old_warnings == pWARN_NONE ||
1708                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1709             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1710         else if (old_warnings == pWARN_ALL ||
1711                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1712             /* Get the bit mask for $warnings::Bits{all}, because
1713              * it could have been extended by warnings::register */
1714             SV **bits_all;
1715             HV * const bits = get_hv("warnings::Bits", FALSE);
1716             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1717                 mask = newSVsv(*bits_all);
1718             }
1719             else {
1720                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1721             }
1722         }
1723         else
1724             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1725         PUSHs(sv_2mortal(mask));
1726     }
1727
1728     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1729           sv_2mortal(newRV_noinc(
1730             (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1731                                               cx->blk_oldcop->cop_hints_hash)))
1732           : &PL_sv_undef);
1733     RETURN;
1734 }
1735
1736 PP(pp_reset)
1737 {
1738     dVAR;
1739     dSP;
1740     const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1741     sv_reset(tmps, CopSTASH(PL_curcop));
1742     PUSHs(&PL_sv_yes);
1743     RETURN;
1744 }
1745
1746 /* like pp_nextstate, but used instead when the debugger is active */
1747
1748 PP(pp_dbstate)
1749 {
1750     dVAR;
1751     PL_curcop = (COP*)PL_op;
1752     TAINT_NOT;          /* Each statement is presumed innocent */
1753     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1754     FREETMPS;
1755
1756     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1757             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1758     {
1759         dSP;
1760         register PERL_CONTEXT *cx;
1761         const I32 gimme = G_ARRAY;
1762         U8 hasargs;
1763         GV * const gv = PL_DBgv;
1764         register CV * const cv = GvCV(gv);
1765
1766         if (!cv)
1767             DIE(aTHX_ "No DB::DB routine defined");
1768
1769         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1770             /* don't do recursive DB::DB call */
1771             return NORMAL;
1772
1773         ENTER;
1774         SAVETMPS;
1775
1776         SAVEI32(PL_debug);
1777         SAVESTACK_POS();
1778         PL_debug = 0;
1779         hasargs = 0;
1780         SPAGAIN;
1781
1782         if (CvISXSUB(cv)) {
1783             CvDEPTH(cv)++;
1784             PUSHMARK(SP);
1785             (void)(*CvXSUB(cv))(aTHX_ cv);
1786             CvDEPTH(cv)--;
1787             FREETMPS;
1788             LEAVE;
1789             return NORMAL;
1790         }
1791         else {
1792             PUSHBLOCK(cx, CXt_SUB, SP);
1793             PUSHSUB_DB(cx);
1794             cx->blk_sub.retop = PL_op->op_next;
1795             CvDEPTH(cv)++;
1796             SAVECOMPPAD();
1797             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1798             RETURNOP(CvSTART(cv));
1799         }
1800     }
1801     else
1802         return NORMAL;
1803 }
1804
1805 PP(pp_enteriter)
1806 {
1807     dVAR; dSP; dMARK;
1808     register PERL_CONTEXT *cx;
1809     const I32 gimme = GIMME_V;
1810     SV **svp;
1811     U16 cxtype = CXt_LOOP | CXp_FOREACH;
1812 #ifdef USE_ITHREADS
1813     void *iterdata;
1814 #endif
1815
1816     ENTER;
1817     SAVETMPS;
1818
1819     if (PL_op->op_targ) {
1820         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1821             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1822             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1823                     SVs_PADSTALE, SVs_PADSTALE);
1824         }
1825 #ifndef USE_ITHREADS
1826         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1827         SAVESPTR(*svp);
1828 #else
1829         SAVEPADSV(PL_op->op_targ);
1830         iterdata = INT2PTR(void*, PL_op->op_targ);
1831         cxtype |= CXp_PADVAR;
1832 #endif
1833     }
1834     else {
1835         GV * const gv = (GV*)POPs;
1836         svp = &GvSV(gv);                        /* symbol table variable */
1837         SAVEGENERICSV(*svp);
1838         *svp = newSV(0);
1839 #ifdef USE_ITHREADS
1840         iterdata = (void*)gv;
1841 #endif
1842     }
1843
1844     if (PL_op->op_private & OPpITER_DEF)
1845         cxtype |= CXp_FOR_DEF;
1846
1847     ENTER;
1848
1849     PUSHBLOCK(cx, cxtype, SP);
1850 #ifdef USE_ITHREADS
1851     PUSHLOOP(cx, iterdata, MARK);
1852 #else
1853     PUSHLOOP(cx, svp, MARK);
1854 #endif
1855     if (PL_op->op_flags & OPf_STACKED) {
1856         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1857         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1858             dPOPss;
1859             SV * const right = (SV*)cx->blk_loop.iterary;
1860             SvGETMAGIC(sv);
1861             SvGETMAGIC(right);
1862             if (RANGE_IS_NUMERIC(sv,right)) {
1863                 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1864                     (SvOK(right) && SvNV(right) >= IV_MAX))
1865                     DIE(aTHX_ "Range iterator outside integer range");
1866                 cx->blk_loop.iterix = SvIV(sv);
1867                 cx->blk_loop.itermax = SvIV(right);
1868 #ifdef DEBUGGING
1869                 /* for correct -Dstv display */
1870                 cx->blk_oldsp = sp - PL_stack_base;
1871 #endif
1872             }
1873             else {
1874                 cx->blk_loop.iterlval = newSVsv(sv);
1875                 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1876                 (void) SvPV_nolen_const(right);
1877             }
1878         }
1879         else if (PL_op->op_private & OPpITER_REVERSED) {
1880             cx->blk_loop.itermax = 0;
1881             cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1882
1883         }
1884     }
1885     else {
1886         cx->blk_loop.iterary = PL_curstack;
1887         AvFILLp(PL_curstack) = SP - PL_stack_base;
1888         if (PL_op->op_private & OPpITER_REVERSED) {
1889             cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1890             cx->blk_loop.iterix = cx->blk_oldsp + 1;
1891         }
1892         else {
1893             cx->blk_loop.iterix = MARK - PL_stack_base;
1894         }
1895     }
1896
1897     RETURN;
1898 }
1899
1900 PP(pp_enterloop)
1901 {
1902     dVAR; dSP;
1903     register PERL_CONTEXT *cx;
1904     const I32 gimme = GIMME_V;
1905
1906     ENTER;
1907     SAVETMPS;
1908     ENTER;
1909
1910     PUSHBLOCK(cx, CXt_LOOP, SP);
1911     PUSHLOOP(cx, 0, SP);
1912
1913     RETURN;
1914 }
1915
1916 PP(pp_leaveloop)
1917 {
1918     dVAR; dSP;
1919     register PERL_CONTEXT *cx;
1920     I32 gimme;
1921     SV **newsp;
1922     PMOP *newpm;
1923     SV **mark;
1924
1925     POPBLOCK(cx,newpm);
1926     assert(CxTYPE(cx) == CXt_LOOP);
1927     mark = newsp;
1928     newsp = PL_stack_base + cx->blk_loop.resetsp;
1929
1930     TAINT_NOT;
1931     if (gimme == G_VOID)
1932         NOOP;
1933     else if (gimme == G_SCALAR) {
1934         if (mark < SP)
1935             *++newsp = sv_mortalcopy(*SP);
1936         else
1937             *++newsp = &PL_sv_undef;
1938     }
1939     else {
1940         while (mark < SP) {
1941             *++newsp = sv_mortalcopy(*++mark);
1942             TAINT_NOT;          /* Each item is independent */
1943         }
1944     }
1945     SP = newsp;
1946     PUTBACK;
1947
1948     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1949     PL_curpm = newpm;   /* ... and pop $1 et al */
1950
1951     LEAVE;
1952     LEAVE;
1953
1954     return NORMAL;
1955 }
1956
1957 PP(pp_return)
1958 {
1959     dVAR; dSP; dMARK;
1960     register PERL_CONTEXT *cx;
1961     bool popsub2 = FALSE;
1962     bool clear_errsv = FALSE;
1963     I32 gimme;
1964     SV **newsp;
1965     PMOP *newpm;
1966     I32 optype = 0;
1967     SV *sv;
1968     OP *retop;
1969
1970     const I32 cxix = dopoptosub(cxstack_ix);
1971
1972     if (cxix < 0) {
1973         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1974                                      * sort block, which is a CXt_NULL
1975                                      * not a CXt_SUB */
1976             dounwind(0);
1977             PL_stack_base[1] = *PL_stack_sp;
1978             PL_stack_sp = PL_stack_base + 1;
1979             return 0;
1980         }
1981         else
1982             DIE(aTHX_ "Can't return outside a subroutine");
1983     }
1984     if (cxix < cxstack_ix)
1985         dounwind(cxix);
1986
1987     if (CxMULTICALL(&cxstack[cxix])) {
1988         gimme = cxstack[cxix].blk_gimme;
1989         if (gimme == G_VOID)
1990             PL_stack_sp = PL_stack_base;
1991         else if (gimme == G_SCALAR) {
1992             PL_stack_base[1] = *PL_stack_sp;
1993             PL_stack_sp = PL_stack_base + 1;
1994         }
1995         return 0;
1996     }
1997
1998     POPBLOCK(cx,newpm);
1999     switch (CxTYPE(cx)) {
2000     case CXt_SUB:
2001         popsub2 = TRUE;
2002         retop = cx->blk_sub.retop;
2003         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2004         break;
2005     case CXt_EVAL:
2006         if (!(PL_in_eval & EVAL_KEEPERR))
2007             clear_errsv = TRUE;
2008         POPEVAL(cx);
2009         retop = cx->blk_eval.retop;
2010         if (CxTRYBLOCK(cx))
2011             break;
2012         lex_end();
2013         if (optype == OP_REQUIRE &&
2014             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2015         {
2016             /* Unassume the success we assumed earlier. */
2017             SV * const nsv = cx->blk_eval.old_namesv;
2018             (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2019             DIE(aTHX_ "%"SVf" did not return a true value", (void*)nsv);
2020         }
2021         break;
2022     case CXt_FORMAT:
2023         POPFORMAT(cx);
2024         retop = cx->blk_sub.retop;
2025         break;
2026     default:
2027         DIE(aTHX_ "panic: return");
2028     }
2029
2030     TAINT_NOT;
2031     if (gimme == G_SCALAR) {
2032         if (MARK < SP) {
2033             if (popsub2) {
2034                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2035                     if (SvTEMP(TOPs)) {
2036                         *++newsp = SvREFCNT_inc(*SP);
2037                         FREETMPS;
2038                         sv_2mortal(*newsp);
2039                     }
2040                     else {
2041                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2042                         FREETMPS;
2043                         *++newsp = sv_mortalcopy(sv);
2044                         SvREFCNT_dec(sv);
2045                     }
2046                 }
2047                 else
2048                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2049             }
2050             else
2051                 *++newsp = sv_mortalcopy(*SP);
2052         }
2053         else
2054             *++newsp = &PL_sv_undef;
2055     }
2056     else if (gimme == G_ARRAY) {
2057         while (++MARK <= SP) {
2058             *++newsp = (popsub2 && SvTEMP(*MARK))
2059                         ? *MARK : sv_mortalcopy(*MARK);
2060             TAINT_NOT;          /* Each item is independent */
2061         }
2062     }
2063     PL_stack_sp = newsp;
2064
2065     LEAVE;
2066     /* Stack values are safe: */
2067     if (popsub2) {
2068         cxstack_ix--;
2069         POPSUB(cx,sv);  /* release CV and @_ ... */
2070     }
2071     else
2072         sv = NULL;
2073     PL_curpm = newpm;   /* ... and pop $1 et al */
2074
2075     LEAVESUB(sv);
2076     if (clear_errsv)
2077         sv_setpvn(ERRSV,"",0);
2078     return retop;
2079 }
2080
2081 PP(pp_last)
2082 {
2083     dVAR; dSP;
2084     I32 cxix;
2085     register PERL_CONTEXT *cx;
2086     I32 pop2 = 0;
2087     I32 gimme;
2088     I32 optype;
2089     OP *nextop;
2090     SV **newsp;
2091     PMOP *newpm;
2092     SV **mark;
2093     SV *sv = NULL;
2094
2095
2096     if (PL_op->op_flags & OPf_SPECIAL) {
2097         cxix = dopoptoloop(cxstack_ix);
2098         if (cxix < 0)
2099             DIE(aTHX_ "Can't \"last\" outside a loop block");
2100     }
2101     else {
2102         cxix = dopoptolabel(cPVOP->op_pv);
2103         if (cxix < 0)
2104             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2105     }
2106     if (cxix < cxstack_ix)
2107         dounwind(cxix);
2108
2109     POPBLOCK(cx,newpm);
2110     cxstack_ix++; /* temporarily protect top context */
2111     mark = newsp;
2112     switch (CxTYPE(cx)) {
2113     case CXt_LOOP:
2114         pop2 = CXt_LOOP;
2115         newsp = PL_stack_base + cx->blk_loop.resetsp;
2116         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2117         break;
2118     case CXt_SUB:
2119         pop2 = CXt_SUB;
2120         nextop = cx->blk_sub.retop;
2121         break;
2122     case CXt_EVAL:
2123         POPEVAL(cx);
2124         nextop = cx->blk_eval.retop;
2125         break;
2126     case CXt_FORMAT:
2127         POPFORMAT(cx);
2128         nextop = cx->blk_sub.retop;
2129         break;
2130     default:
2131         DIE(aTHX_ "panic: last");
2132     }
2133
2134     TAINT_NOT;
2135     if (gimme == G_SCALAR) {
2136         if (MARK < SP)
2137             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2138                         ? *SP : sv_mortalcopy(*SP);
2139         else
2140             *++newsp = &PL_sv_undef;
2141     }
2142     else if (gimme == G_ARRAY) {
2143         while (++MARK <= SP) {
2144             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2145                         ? *MARK : sv_mortalcopy(*MARK);
2146             TAINT_NOT;          /* Each item is independent */
2147         }
2148     }
2149     SP = newsp;
2150     PUTBACK;
2151
2152     LEAVE;
2153     cxstack_ix--;
2154     /* Stack values are safe: */
2155     switch (pop2) {
2156     case CXt_LOOP:
2157         POPLOOP(cx);    /* release loop vars ... */
2158         LEAVE;
2159         break;
2160     case CXt_SUB:
2161         POPSUB(cx,sv);  /* release CV and @_ ... */
2162         break;
2163     }
2164     PL_curpm = newpm;   /* ... and pop $1 et al */
2165
2166     LEAVESUB(sv);
2167     PERL_UNUSED_VAR(optype);
2168     PERL_UNUSED_VAR(gimme);
2169     return nextop;
2170 }
2171
2172 PP(pp_next)
2173 {
2174     dVAR;
2175     I32 cxix;
2176     register PERL_CONTEXT *cx;
2177     I32 inner;
2178
2179     if (PL_op->op_flags & OPf_SPECIAL) {
2180         cxix = dopoptoloop(cxstack_ix);
2181         if (cxix < 0)
2182             DIE(aTHX_ "Can't \"next\" outside a loop block");
2183     }
2184     else {
2185         cxix = dopoptolabel(cPVOP->op_pv);
2186         if (cxix < 0)
2187             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2188     }
2189     if (cxix < cxstack_ix)
2190         dounwind(cxix);
2191
2192     /* clear off anything above the scope we're re-entering, but
2193      * save the rest until after a possible continue block */
2194     inner = PL_scopestack_ix;
2195     TOPBLOCK(cx);
2196     if (PL_scopestack_ix < inner)
2197         leave_scope(PL_scopestack[PL_scopestack_ix]);
2198     PL_curcop = cx->blk_oldcop;
2199     return CX_LOOP_NEXTOP_GET(cx);
2200 }
2201
2202 PP(pp_redo)
2203 {
2204     dVAR;
2205     I32 cxix;
2206     register PERL_CONTEXT *cx;
2207     I32 oldsave;
2208     OP* redo_op;
2209
2210     if (PL_op->op_flags & OPf_SPECIAL) {
2211         cxix = dopoptoloop(cxstack_ix);
2212         if (cxix < 0)
2213             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2214     }
2215     else {
2216         cxix = dopoptolabel(cPVOP->op_pv);
2217         if (cxix < 0)
2218             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2219     }
2220     if (cxix < cxstack_ix)
2221         dounwind(cxix);
2222
2223     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2224     if (redo_op->op_type == OP_ENTER) {
2225         /* pop one less context to avoid $x being freed in while (my $x..) */
2226         cxstack_ix++;
2227         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2228         redo_op = redo_op->op_next;
2229     }
2230
2231     TOPBLOCK(cx);
2232     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2233     LEAVE_SCOPE(oldsave);
2234     FREETMPS;
2235     PL_curcop = cx->blk_oldcop;
2236     return redo_op;
2237 }
2238
2239 STATIC OP *
2240 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2241 {
2242     dVAR;
2243     OP **ops = opstack;
2244     static const char too_deep[] = "Target of goto is too deeply nested";
2245
2246     if (ops >= oplimit)
2247         Perl_croak(aTHX_ too_deep);
2248     if (o->op_type == OP_LEAVE ||
2249         o->op_type == OP_SCOPE ||
2250         o->op_type == OP_LEAVELOOP ||
2251         o->op_type == OP_LEAVESUB ||
2252         o->op_type == OP_LEAVETRY)
2253     {
2254         *ops++ = cUNOPo->op_first;
2255         if (ops >= oplimit)
2256             Perl_croak(aTHX_ too_deep);
2257     }
2258     *ops = 0;
2259     if (o->op_flags & OPf_KIDS) {
2260         OP *kid;
2261         /* First try all the kids at this level, since that's likeliest. */
2262         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2263             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2264                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2265                 return kid;
2266         }
2267         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2268             if (kid == PL_lastgotoprobe)
2269                 continue;
2270             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2271                 if (ops == opstack)
2272                     *ops++ = kid;
2273                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2274                          ops[-1]->op_type == OP_DBSTATE)
2275                     ops[-1] = kid;
2276                 else
2277                     *ops++ = kid;
2278             }
2279             if ((o = dofindlabel(kid, label, ops, oplimit)))
2280                 return o;
2281         }
2282     }
2283     *ops = 0;
2284     return 0;
2285 }
2286
2287 PP(pp_goto)
2288 {
2289     dVAR; dSP;
2290     OP *retop = NULL;
2291     I32 ix;
2292     register PERL_CONTEXT *cx;
2293 #define GOTO_DEPTH 64
2294     OP *enterops[GOTO_DEPTH];
2295     const char *label = NULL;
2296     const bool do_dump = (PL_op->op_type == OP_DUMP);
2297     static const char must_have_label[] = "goto must have label";
2298
2299     if (PL_op->op_flags & OPf_STACKED) {
2300         SV * const sv = POPs;
2301
2302         /* This egregious kludge implements goto &subroutine */
2303         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2304             I32 cxix;
2305             register PERL_CONTEXT *cx;
2306             CV* cv = (CV*)SvRV(sv);
2307             SV** mark;
2308             I32 items = 0;
2309             I32 oldsave;
2310             bool reified = 0;
2311
2312         retry:
2313             if (!CvROOT(cv) && !CvXSUB(cv)) {
2314                 const GV * const gv = CvGV(cv);
2315                 if (gv) {
2316                     GV *autogv;
2317                     SV *tmpstr;
2318                     /* autoloaded stub? */
2319                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2320                         goto retry;
2321                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2322                                           GvNAMELEN(gv), FALSE);
2323                     if (autogv && (cv = GvCV(autogv)))
2324                         goto retry;
2325                     tmpstr = sv_newmortal();
2326                     gv_efullname3(tmpstr, gv, NULL);
2327                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",(void*)tmpstr);
2328                 }
2329                 DIE(aTHX_ "Goto undefined subroutine");
2330             }
2331
2332             /* First do some returnish stuff. */
2333             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2334             FREETMPS;
2335             cxix = dopoptosub(cxstack_ix);
2336             if (cxix < 0)
2337                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2338             if (cxix < cxstack_ix)
2339                 dounwind(cxix);
2340             TOPBLOCK(cx);
2341             SPAGAIN;
2342             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2343             if (CxTYPE(cx) == CXt_EVAL) {
2344                 if (CxREALEVAL(cx))
2345                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2346                 else
2347                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2348             }
2349             else if (CxMULTICALL(cx))
2350                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2351             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2352                 /* put @_ back onto stack */
2353                 AV* av = cx->blk_sub.argarray;
2354
2355                 items = AvFILLp(av) + 1;
2356                 EXTEND(SP, items+1); /* @_ could have been extended. */
2357                 Copy(AvARRAY(av), SP + 1, items, SV*);
2358                 SvREFCNT_dec(GvAV(PL_defgv));
2359                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2360                 CLEAR_ARGARRAY(av);
2361                 /* abandon @_ if it got reified */
2362                 if (AvREAL(av)) {
2363                     reified = 1;
2364                     SvREFCNT_dec(av);
2365                     av = newAV();
2366                     av_extend(av, items-1);
2367                     AvREIFY_only(av);
2368                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2369                 }
2370             }
2371             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2372                 AV* const av = GvAV(PL_defgv);
2373                 items = AvFILLp(av) + 1;
2374                 EXTEND(SP, items+1); /* @_ could have been extended. */
2375                 Copy(AvARRAY(av), SP + 1, items, SV*);
2376             }
2377             mark = SP;
2378             SP += items;
2379             if (CxTYPE(cx) == CXt_SUB &&
2380                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2381                 SvREFCNT_dec(cx->blk_sub.cv);
2382             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2383             LEAVE_SCOPE(oldsave);
2384
2385             /* Now do some callish stuff. */
2386             SAVETMPS;
2387             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2388             if (CvISXSUB(cv)) {
2389                 OP* const retop = cx->blk_sub.retop;
2390                 SV **newsp;
2391                 I32 gimme;
2392                 if (reified) {
2393                     I32 index;
2394                     for (index=0; index<items; index++)
2395                         sv_2mortal(SP[-index]);
2396                 }
2397
2398                 /* XS subs don't have a CxSUB, so pop it */
2399                 POPBLOCK(cx, PL_curpm);
2400                 /* Push a mark for the start of arglist */
2401                 PUSHMARK(mark);
2402                 PUTBACK;
2403                 (void)(*CvXSUB(cv))(aTHX_ cv);
2404                 LEAVE;
2405                 return retop;
2406             }
2407             else {
2408                 AV* const padlist = CvPADLIST(cv);
2409                 if (CxTYPE(cx) == CXt_EVAL) {
2410                     PL_in_eval = cx->blk_eval.old_in_eval;
2411                     PL_eval_root = cx->blk_eval.old_eval_root;
2412                     cx->cx_type = CXt_SUB;
2413                     cx->blk_sub.hasargs = 0;
2414                 }
2415                 cx->blk_sub.cv = cv;
2416                 cx->blk_sub.olddepth = CvDEPTH(cv);
2417
2418                 CvDEPTH(cv)++;
2419                 if (CvDEPTH(cv) < 2)
2420                     SvREFCNT_inc_simple_void_NN(cv);
2421                 else {
2422                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2423                         sub_crush_depth(cv);
2424                     pad_push(padlist, CvDEPTH(cv));
2425                 }
2426                 SAVECOMPPAD();
2427                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2428                 if (cx->blk_sub.hasargs)
2429                 {
2430                     AV* const av = (AV*)PAD_SVl(0);
2431
2432                     cx->blk_sub.savearray = GvAV(PL_defgv);
2433                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2434                     CX_CURPAD_SAVE(cx->blk_sub);
2435                     cx->blk_sub.argarray = av;
2436
2437                     if (items >= AvMAX(av) + 1) {
2438                         SV **ary = AvALLOC(av);
2439                         if (AvARRAY(av) != ary) {
2440                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2441                             SvPV_set(av, (char*)ary);
2442                         }
2443                         if (items >= AvMAX(av) + 1) {
2444                             AvMAX(av) = items - 1;
2445                             Renew(ary,items+1,SV*);
2446                             AvALLOC(av) = ary;
2447                             SvPV_set(av, (char*)ary);
2448                         }
2449                     }
2450                     ++mark;
2451                     Copy(mark,AvARRAY(av),items,SV*);
2452                     AvFILLp(av) = items - 1;
2453                     assert(!AvREAL(av));
2454                     if (reified) {
2455                         /* transfer 'ownership' of refcnts to new @_ */
2456                         AvREAL_on(av);
2457                         AvREIFY_off(av);
2458                     }
2459                     while (items--) {
2460                         if (*mark)
2461                             SvTEMP_off(*mark);
2462                         mark++;
2463                     }
2464                 }
2465                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2466                     /*
2467                      * We do not care about using sv to call CV;
2468                      * it's for informational purposes only.
2469                      */
2470                     SV * const sv = GvSV(PL_DBsub);
2471                     save_item(sv);
2472                     if (PERLDB_SUB_NN) {
2473                         const int type = SvTYPE(sv);
2474                         if (type < SVt_PVIV && type != SVt_IV)
2475                             sv_upgrade(sv, SVt_PVIV);
2476                         (void)SvIOK_on(sv);
2477                         SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2478                     } else {
2479                         gv_efullname3(sv, CvGV(cv), NULL);
2480                     }
2481                     if (PERLDB_GOTO) {
2482                         CV * const gotocv = get_cv("DB::goto", FALSE);
2483                         if (gotocv) {
2484                             PUSHMARK( PL_stack_sp );
2485                             call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2486                             PL_stack_sp--;
2487                         }
2488                     }
2489                 }
2490                 RETURNOP(CvSTART(cv));
2491             }
2492         }
2493         else {
2494             label = SvPV_nolen_const(sv);
2495             if (!(do_dump || *label))
2496                 DIE(aTHX_ must_have_label);
2497         }
2498     }
2499     else if (PL_op->op_flags & OPf_SPECIAL) {
2500         if (! do_dump)
2501             DIE(aTHX_ must_have_label);
2502     }
2503     else
2504         label = cPVOP->op_pv;
2505
2506     if (label && *label) {
2507         OP *gotoprobe = NULL;
2508         bool leaving_eval = FALSE;
2509         bool in_block = FALSE;
2510         PERL_CONTEXT *last_eval_cx = NULL;
2511
2512         /* find label */
2513
2514         PL_lastgotoprobe = NULL;
2515         *enterops = 0;
2516         for (ix = cxstack_ix; ix >= 0; ix--) {
2517             cx = &cxstack[ix];
2518             switch (CxTYPE(cx)) {
2519             case CXt_EVAL:
2520                 leaving_eval = TRUE;
2521                 if (!CxTRYBLOCK(cx)) {
2522                     gotoprobe = (last_eval_cx ?
2523                                 last_eval_cx->blk_eval.old_eval_root :
2524                                 PL_eval_root);
2525                     last_eval_cx = cx;
2526                     break;
2527                 }
2528                 /* else fall through */
2529             case CXt_LOOP:
2530                 gotoprobe = cx->blk_oldcop->op_sibling;
2531                 break;
2532             case CXt_SUBST:
2533                 continue;
2534             case CXt_BLOCK:
2535                 if (ix) {
2536                     gotoprobe = cx->blk_oldcop->op_sibling;
2537                     in_block = TRUE;
2538                 } else
2539                     gotoprobe = PL_main_root;
2540                 break;
2541             case CXt_SUB:
2542                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2543                     gotoprobe = CvROOT(cx->blk_sub.cv);
2544                     break;
2545                 }
2546                 /* FALL THROUGH */
2547             case CXt_FORMAT:
2548             case CXt_NULL:
2549                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2550             default:
2551                 if (ix)
2552                     DIE(aTHX_ "panic: goto");
2553                 gotoprobe = PL_main_root;
2554                 break;
2555             }
2556             if (gotoprobe) {
2557                 retop = dofindlabel(gotoprobe, label,
2558                                     enterops, enterops + GOTO_DEPTH);
2559                 if (retop)
2560                     break;
2561             }
2562             PL_lastgotoprobe = gotoprobe;
2563         }
2564         if (!retop)
2565             DIE(aTHX_ "Can't find label %s", label);
2566
2567         /* if we're leaving an eval, check before we pop any frames
2568            that we're not going to punt, otherwise the error
2569            won't be caught */
2570
2571         if (leaving_eval && *enterops && enterops[1]) {
2572             I32 i;
2573             for (i = 1; enterops[i]; i++)
2574                 if (enterops[i]->op_type == OP_ENTERITER)
2575                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2576         }
2577
2578         /* pop unwanted frames */
2579
2580         if (ix < cxstack_ix) {
2581             I32 oldsave;
2582
2583             if (ix < 0)
2584                 ix = 0;
2585             dounwind(ix);
2586             TOPBLOCK(cx);
2587             oldsave = PL_scopestack[PL_scopestack_ix];
2588             LEAVE_SCOPE(oldsave);
2589         }
2590
2591         /* push wanted frames */
2592
2593         if (*enterops && enterops[1]) {
2594             OP * const oldop = PL_op;
2595             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2596             for (; enterops[ix]; ix++) {
2597                 PL_op = enterops[ix];
2598                 /* Eventually we may want to stack the needed arguments
2599                  * for each op.  For now, we punt on the hard ones. */
2600                 if (PL_op->op_type == OP_ENTERITER)
2601                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2602                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2603             }
2604             PL_op = oldop;
2605         }
2606     }
2607
2608     if (do_dump) {
2609 #ifdef VMS
2610         if (!retop) retop = PL_main_start;
2611 #endif
2612         PL_restartop = retop;
2613         PL_do_undump = TRUE;
2614
2615         my_unexec();
2616
2617         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2618         PL_do_undump = FALSE;
2619     }
2620
2621     RETURNOP(retop);
2622 }
2623
2624 PP(pp_exit)
2625 {
2626     dVAR;
2627     dSP;
2628     I32 anum;
2629
2630     if (MAXARG < 1)
2631         anum = 0;
2632     else {
2633         anum = SvIVx(POPs);
2634 #ifdef VMS
2635         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2636             anum = 0;
2637         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2638 #endif
2639     }
2640     PL_exit_flags |= PERL_EXIT_EXPECTED;
2641 #ifdef PERL_MAD
2642     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2643     if (anum || !(PL_minus_c && PL_madskills))
2644         my_exit(anum);
2645 #else
2646     my_exit(anum);
2647 #endif
2648     PUSHs(&PL_sv_undef);
2649     RETURN;
2650 }
2651
2652 /* Eval. */
2653
2654 STATIC void
2655 S_save_lines(pTHX_ AV *array, SV *sv)
2656 {
2657     const char *s = SvPVX_const(sv);
2658     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2659     I32 line = 1;
2660
2661     while (s && s < send) {
2662         const char *t;
2663         SV * const tmpstr = newSV(0);
2664
2665         sv_upgrade(tmpstr, SVt_PVMG);
2666         t = strchr(s, '\n');
2667         if (t)
2668             t++;
2669         else
2670             t = send;
2671
2672         sv_setpvn(tmpstr, s, t - s);
2673         av_store(array, line++, tmpstr);
2674         s = t;
2675     }
2676 }
2677
2678 STATIC void
2679 S_docatch_body(pTHX)
2680 {
2681     dVAR;
2682     CALLRUNOPS(aTHX);
2683     return;
2684 }
2685
2686 STATIC OP *
2687 S_docatch(pTHX_ OP *o)
2688 {
2689     dVAR;
2690     int ret;
2691     OP * const oldop = PL_op;
2692     dJMPENV;
2693
2694 #ifdef DEBUGGING
2695     assert(CATCH_GET == TRUE);
2696 #endif
2697     PL_op = o;
2698
2699     JMPENV_PUSH(ret);
2700     switch (ret) {
2701     case 0:
2702         assert(cxstack_ix >= 0);
2703         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2704         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2705  redo_body:
2706         docatch_body();
2707         break;
2708     case 3:
2709         /* die caught by an inner eval - continue inner loop */
2710
2711         /* NB XXX we rely on the old popped CxEVAL still being at the top
2712          * of the stack; the way die_where() currently works, this
2713          * assumption is valid. In theory The cur_top_env value should be
2714          * returned in another global, the way retop (aka PL_restartop)
2715          * is. */
2716         assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2717
2718         if (PL_restartop
2719             && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2720         {
2721             PL_op = PL_restartop;
2722             PL_restartop = 0;
2723             goto redo_body;
2724         }
2725         /* FALL THROUGH */
2726     default:
2727         JMPENV_POP;
2728         PL_op = oldop;
2729         JMPENV_JUMP(ret);
2730         /* NOTREACHED */
2731     }
2732     JMPENV_POP;
2733     PL_op = oldop;
2734     return NULL;
2735 }
2736
2737 OP *
2738 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2739 /* sv Text to convert to OP tree. */
2740 /* startop op_free() this to undo. */
2741 /* code Short string id of the caller. */
2742 {
2743     /* FIXME - how much of this code is common with pp_entereval?  */
2744     dVAR; dSP;                          /* Make POPBLOCK work. */
2745     PERL_CONTEXT *cx;
2746     SV **newsp;
2747     I32 gimme = G_VOID;
2748     I32 optype;
2749     OP dummy;
2750     OP *rop;
2751     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2752     char *tmpbuf = tbuf;
2753     char *safestr;
2754     int runtime;
2755     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
2756     STRLEN len;
2757
2758     ENTER;
2759     lex_start(sv);
2760     SAVETMPS;
2761     /* switch to eval mode */
2762
2763     if (IN_PERL_COMPILETIME) {
2764         SAVECOPSTASH_FREE(&PL_compiling);
2765         CopSTASH_set(&PL_compiling, PL_curstash);
2766     }
2767     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2768         SV * const sv = sv_newmortal();
2769         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2770                        code, (unsigned long)++PL_evalseq,
2771                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2772         tmpbuf = SvPVX(sv);
2773         len = SvCUR(sv);
2774     }
2775     else
2776         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2777                           (unsigned long)++PL_evalseq);
2778     SAVECOPFILE_FREE(&PL_compiling);
2779     CopFILE_set(&PL_compiling, tmpbuf+2);
2780     SAVECOPLINE(&PL_compiling);
2781     CopLINE_set(&PL_compiling, 1);
2782     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2783        deleting the eval's FILEGV from the stash before gv_check() runs
2784        (i.e. before run-time proper). To work around the coredump that
2785        ensues, we always turn GvMULTI_on for any globals that were
2786        introduced within evals. See force_ident(). GSAR 96-10-12 */
2787     safestr = savepvn(tmpbuf, len);
2788     SAVEDELETE(PL_defstash, safestr, len);
2789     SAVEHINTS();
2790 #ifdef OP_IN_REGISTER
2791     PL_opsave = op;
2792 #else
2793     SAVEVPTR(PL_op);
2794 #endif
2795
2796     /* we get here either during compilation, or via pp_regcomp at runtime */
2797     runtime = IN_PERL_RUNTIME;
2798     if (runtime)
2799         runcv = find_runcv(NULL);
2800
2801     PL_op = &dummy;
2802     PL_op->op_type = OP_ENTEREVAL;
2803     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2804     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2805     PUSHEVAL(cx, 0, NULL);
2806
2807     if (runtime)
2808         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2809     else
2810         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2811     POPBLOCK(cx,PL_curpm);
2812     POPEVAL(cx);
2813
2814     (*startop)->op_type = OP_NULL;
2815     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2816     lex_end();
2817     /* XXX DAPM do this properly one year */
2818     *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2819     LEAVE;
2820     if (IN_PERL_COMPILETIME)
2821         CopHINTS_set(&PL_compiling, PL_hints);
2822 #ifdef OP_IN_REGISTER
2823     op = PL_opsave;
2824 #endif
2825     PERL_UNUSED_VAR(newsp);
2826     PERL_UNUSED_VAR(optype);
2827
2828     return rop;
2829 }
2830
2831
2832 /*
2833 =for apidoc find_runcv
2834
2835 Locate the CV corresponding to the currently executing sub or eval.
2836 If db_seqp is non_null, skip CVs that are in the DB package and populate
2837 *db_seqp with the cop sequence number at the point that the DB:: code was
2838 entered. (allows debuggers to eval in the scope of the breakpoint rather
2839 than in the scope of the debugger itself).
2840
2841 =cut
2842 */
2843
2844 CV*
2845 Perl_find_runcv(pTHX_ U32 *db_seqp)
2846 {
2847     dVAR;
2848     PERL_SI      *si;
2849
2850     if (db_seqp)
2851         *db_seqp = PL_curcop->cop_seq;
2852     for (si = PL_curstackinfo; si; si = si->si_prev) {
2853         I32 ix;
2854         for (ix = si->si_cxix; ix >= 0; ix--) {
2855             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2856             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2857                 CV * const cv = cx->blk_sub.cv;
2858                 /* skip DB:: code */
2859                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2860                     *db_seqp = cx->blk_oldcop->cop_seq;
2861                     continue;
2862                 }
2863                 return cv;
2864             }
2865             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2866                 return PL_compcv;
2867         }
2868     }
2869     return PL_main_cv;
2870 }
2871
2872
2873 /* Compile a require/do, an eval '', or a /(?{...})/.
2874  * In the last case, startop is non-null, and contains the address of
2875  * a pointer that should be set to the just-compiled code.
2876  * outside is the lexically enclosing CV (if any) that invoked us.
2877  */
2878
2879 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2880 STATIC OP *
2881 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2882 {
2883     dVAR; dSP;
2884     OP * const saveop = PL_op;
2885
2886     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2887                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2888                   : EVAL_INEVAL);
2889
2890     PUSHMARK(SP);
2891
2892     SAVESPTR(PL_compcv);
2893     PL_compcv = (CV*)newSV(0);
2894     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2895     CvEVAL_on(PL_compcv);
2896     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2897     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2898
2899     CvOUTSIDE_SEQ(PL_compcv) = seq;
2900     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2901
2902     /* set up a scratch pad */
2903
2904     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2905     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2906
2907
2908     if (!PL_madskills)
2909         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
2910
2911     /* make sure we compile in the right package */
2912
2913     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2914         SAVESPTR(PL_curstash);
2915         PL_curstash = CopSTASH(PL_curcop);
2916     }
2917     SAVESPTR(PL_beginav);
2918     PL_beginav = newAV();
2919     SAVEFREESV(PL_beginav);
2920     SAVEI32(PL_error_count);
2921
2922 #ifdef PERL_MAD
2923     SAVEI32(PL_madskills);
2924     PL_madskills = 0;
2925 #endif
2926
2927     /* try to compile it */
2928
2929     PL_eval_root = NULL;
2930     PL_error_count = 0;
2931     PL_curcop = &PL_compiling;
2932     CopARYBASE_set(PL_curcop, 0);
2933     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2934         PL_in_eval |= EVAL_KEEPERR;
2935     else
2936         sv_setpvn(ERRSV,"",0);
2937     if (yyparse() || PL_error_count || !PL_eval_root) {
2938         SV **newsp;                     /* Used by POPBLOCK. */
2939         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2940         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2941         const char *msg;
2942
2943         PL_op = saveop;
2944         if (PL_eval_root) {
2945             op_free(PL_eval_root);
2946             PL_eval_root = NULL;
2947         }
2948         SP = PL_stack_base + POPMARK;           /* pop original mark */
2949         if (!startop) {
2950             POPBLOCK(cx,PL_curpm);
2951             POPEVAL(cx);
2952         }
2953         lex_end();
2954         LEAVE;
2955
2956         msg = SvPVx_nolen_const(ERRSV);
2957         if (optype == OP_REQUIRE) {
2958             const SV * const nsv = cx->blk_eval.old_namesv;
2959             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2960                           &PL_sv_undef, 0);
2961             DIE(aTHX_ "%sCompilation failed in require",
2962                 *msg ? msg : "Unknown error\n");
2963         }
2964         else if (startop) {
2965             POPBLOCK(cx,PL_curpm);
2966             POPEVAL(cx);
2967             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2968                        (*msg ? msg : "Unknown error\n"));
2969         }
2970         else {
2971             if (!*msg) {
2972                 sv_setpv(ERRSV, "Compilation error");
2973             }
2974         }
2975         PERL_UNUSED_VAR(newsp);
2976         RETPUSHUNDEF;
2977     }
2978     CopLINE_set(&PL_compiling, 0);
2979     if (startop) {
2980         *startop = PL_eval_root;
2981     } else
2982         SAVEFREEOP(PL_eval_root);
2983
2984     /* Set the context for this new optree.
2985      * If the last op is an OP_REQUIRE, force scalar context.
2986      * Otherwise, propagate the context from the eval(). */
2987     if (PL_eval_root->op_type == OP_LEAVEEVAL
2988             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2989             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2990             == OP_REQUIRE)
2991         scalar(PL_eval_root);
2992     else if (gimme & G_VOID)
2993         scalarvoid(PL_eval_root);
2994     else if (gimme & G_ARRAY)
2995         list(PL_eval_root);
2996     else
2997         scalar(PL_eval_root);
2998
2999     DEBUG_x(dump_eval());
3000
3001     /* Register with debugger: */
3002     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3003         CV * const cv = get_cv("DB::postponed", FALSE);
3004         if (cv) {
3005             dSP;
3006             PUSHMARK(SP);
3007             XPUSHs((SV*)CopFILEGV(&PL_compiling));
3008             PUTBACK;
3009             call_sv((SV*)cv, G_DISCARD);
3010         }
3011     }
3012
3013     /* compiled okay, so do it */
3014
3015     CvDEPTH(PL_compcv) = 1;
3016     SP = PL_stack_base + POPMARK;               /* pop original mark */
3017     PL_op = saveop;                     /* The caller may need it. */
3018     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3019
3020     RETURNOP(PL_eval_start);
3021 }
3022
3023 STATIC PerlIO *
3024 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3025 {
3026     Stat_t st;
3027     const int st_rc = PerlLIO_stat(name, &st);
3028
3029     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3030         return NULL;
3031     }
3032
3033     return PerlIO_open(name, mode);
3034 }
3035
3036 STATIC PerlIO *
3037 S_doopen_pm(pTHX_ const char *name, const char *mode)
3038 {
3039 #ifndef PERL_DISABLE_PMC
3040     const STRLEN namelen = strlen(name);
3041     PerlIO *fp;
3042
3043     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3044         SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3045         const char * const pmc = SvPV_nolen_const(pmcsv);
3046         Stat_t pmcstat;
3047         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3048             fp = check_type_and_open(name, mode);
3049         }
3050         else {
3051             fp = check_type_and_open(pmc, mode);
3052         }
3053         SvREFCNT_dec(pmcsv);
3054     }
3055     else {
3056         fp = check_type_and_open(name, mode);
3057     }
3058     return fp;
3059 #else
3060     return check_type_and_open(name, mode);
3061 #endif /* !PERL_DISABLE_PMC */
3062 }
3063
3064 PP(pp_require)
3065 {
3066     dVAR; dSP;
3067     register PERL_CONTEXT *cx;
3068     SV *sv;
3069     const char *name;
3070     STRLEN len;
3071     const char *tryname = NULL;
3072     SV *namesv = NULL;
3073     const I32 gimme = GIMME_V;
3074     int filter_has_file = 0;
3075     PerlIO *tryrsfp = NULL;
3076     SV *filter_cache = NULL;
3077     SV *filter_state = NULL;
3078     SV *filter_sub = NULL;
3079     SV *hook_sv = NULL;
3080     SV *encoding;
3081     OP *op;
3082
3083     sv = POPs;
3084     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3085         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )       /* require v5.6.1 */
3086                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3087                         "v-string in use/require non-portable");
3088
3089         sv = new_version(sv);
3090         if (!sv_derived_from(PL_patchlevel, "version"))
3091             upg_version(PL_patchlevel);
3092         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3093             if ( vcmp(sv,PL_patchlevel) <= 0 )
3094                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3095                     (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
3096         }
3097         else {
3098             if ( vcmp(sv,PL_patchlevel) > 0 )
3099                 DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped",
3100                     (void*)vnormal(sv), (void*)vnormal(PL_patchlevel));
3101         }
3102
3103             RETPUSHYES;
3104     }
3105     name = SvPV_const(sv, len);
3106     if (!(name && len > 0 && *name))
3107         DIE(aTHX_ "Null filename used");
3108     TAINT_PROPER("require");
3109     if (PL_op->op_type == OP_REQUIRE) {
3110         SV * const * const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3111         if ( svp ) {
3112             if (*svp != &PL_sv_undef)
3113                 RETPUSHYES;
3114             else
3115                 DIE(aTHX_ "Compilation failed in require");
3116         }
3117     }
3118
3119     /* prepare to compile file */
3120
3121     if (path_is_absolute(name)) {
3122         tryname = name;
3123         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3124     }
3125 #ifdef MACOS_TRADITIONAL
3126     if (!tryrsfp) {
3127         char newname[256];
3128
3129         MacPerl_CanonDir(name, newname, 1);
3130         if (path_is_absolute(newname)) {
3131             tryname = newname;
3132             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3133         }
3134     }
3135 #endif
3136     if (!tryrsfp) {
3137         AV * const ar = GvAVn(PL_incgv);
3138         I32 i;
3139 #ifdef VMS
3140         char *unixname;
3141         if ((unixname = tounixspec(name, NULL)) != NULL)
3142 #endif
3143         {
3144             namesv = newSV(0);
3145             for (i = 0; i <= AvFILL(ar); i++) {
3146                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3147
3148                 if (SvROK(dirsv)) {
3149                     int count;
3150                     SV *loader = dirsv;
3151
3152                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3153                         && !sv_isobject(loader))
3154                     {
3155                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3156                     }
3157
3158                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3159                                    PTR2UV(SvRV(dirsv)), name);
3160                     tryname = SvPVX_const(namesv);
3161                     tryrsfp = NULL;
3162
3163                     ENTER;
3164                     SAVETMPS;
3165                     EXTEND(SP, 2);
3166
3167                     PUSHMARK(SP);
3168                     PUSHs(dirsv);
3169                     PUSHs(sv);
3170                     PUTBACK;
3171                     if (sv_isobject(loader))
3172                         count = call_method("INC", G_ARRAY);
3173                     else
3174                         count = call_sv(loader, G_ARRAY);
3175                     SPAGAIN;
3176
3177                     if (count > 0) {
3178                         int i = 0;
3179                         SV *arg;
3180
3181                         SP -= count - 1;
3182                         arg = SP[i++];
3183
3184                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3185                             && !isGV_with_GP(SvRV(arg))) {
3186                             filter_cache = SvRV(arg);
3187                             SvREFCNT_inc_simple_void_NN(filter_cache);
3188
3189                             if (i < count) {
3190                                 arg = SP[i++];
3191                             }
3192                         }
3193
3194                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3195                             arg = SvRV(arg);
3196                         }
3197
3198                         if (SvTYPE(arg) == SVt_PVGV) {
3199                             IO * const io = GvIO((GV *)arg);
3200
3201                             ++filter_has_file;
3202
3203                             if (io) {
3204                                 tryrsfp = IoIFP(io);
3205                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3206                                     PerlIO_close(IoOFP(io));
3207                                 }
3208                                 IoIFP(io) = NULL;
3209                                 IoOFP(io) = NULL;
3210                             }
3211
3212                             if (i < count) {
3213                                 arg = SP[i++];
3214                             }
3215                         }
3216
3217                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3218                             filter_sub = arg;
3219                             SvREFCNT_inc_simple_void_NN(filter_sub);
3220
3221                             if (i < count) {
3222                                 filter_state = SP[i];
3223                                 SvREFCNT_inc_simple_void(filter_state);
3224                             }
3225                         }
3226
3227                         if (!tryrsfp && (filter_cache || filter_sub)) {
3228                             tryrsfp = PerlIO_open(BIT_BUCKET,
3229                                                   PERL_SCRIPT_MODE);
3230                         }
3231                         SP--;
3232                     }
3233
3234                     PUTBACK;
3235                     FREETMPS;
3236                     LEAVE;
3237
3238                     if (tryrsfp) {
3239                         hook_sv = dirsv;
3240                         break;
3241                     }
3242
3243                     filter_has_file = 0;
3244                     if (filter_cache) {
3245                         SvREFCNT_dec(filter_cache);
3246                         filter_cache = NULL;
3247                     }
3248                     if (filter_state) {
3249                         SvREFCNT_dec(filter_state);
3250                         filter_state = NULL;
3251                     }
3252                     if (filter_sub) {
3253                         SvREFCNT_dec(filter_sub);
3254                         filter_sub = NULL;
3255                     }
3256                 }
3257                 else {
3258                   if (!path_is_absolute(name)
3259 #ifdef MACOS_TRADITIONAL
3260                         /* We consider paths of the form :a:b ambiguous and interpret them first
3261                            as global then as local
3262                         */
3263                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3264 #endif
3265                   ) {
3266                     const char *dir = SvPVx_nolen_const(dirsv);
3267 #ifdef MACOS_TRADITIONAL
3268                     char buf1[256];
3269                     char buf2[256];
3270
3271                     MacPerl_CanonDir(name, buf2, 1);
3272                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3273 #else
3274 #  ifdef VMS
3275                     char *unixdir;
3276                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3277                         continue;
3278                     sv_setpv(namesv, unixdir);
3279                     sv_catpv(namesv, unixname);
3280 #  else
3281 #    ifdef __SYMBIAN32__
3282                     if (PL_origfilename[0] &&
3283                         PL_origfilename[1] == ':' &&
3284                         !(dir[0] && dir[1] == ':'))
3285                         Perl_sv_setpvf(aTHX_ namesv,
3286                                        "%c:%s\\%s",
3287                                        PL_origfilename[0],
3288                                        dir, name);
3289                     else
3290                         Perl_sv_setpvf(aTHX_ namesv,
3291                                        "%s\\%s",
3292                                        dir, name);
3293 #    else
3294                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3295 #    endif
3296 #  endif
3297 #endif
3298                     TAINT_PROPER("require");
3299                     tryname = SvPVX_const(namesv);
3300                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3301                     if (tryrsfp) {
3302                         if (tryname[0] == '.' && tryname[1] == '/')
3303                             tryname += 2;
3304                         break;
3305                     }
3306                     else if (errno == EMFILE)
3307                         /* no point in trying other paths if out of handles */
3308                         break;
3309                   }
3310                 }
3311             }
3312         }
3313     }
3314     SAVECOPFILE_FREE(&PL_compiling);
3315     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3316     SvREFCNT_dec(namesv);
3317     if (!tryrsfp) {
3318         if (PL_op->op_type == OP_REQUIRE) {
3319             const char *msgstr = name;
3320             if(errno == EMFILE) {
3321                 SV * const msg
3322                     = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
3323                                                Strerror(errno)));
3324                 msgstr = SvPV_nolen_const(msg);
3325             } else {
3326                 if (namesv) {                   /* did we lookup @INC? */
3327                     AV * const ar = GvAVn(PL_incgv);
3328                     I32 i;
3329                     SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3330                         "%s in @INC%s%s (@INC contains:",
3331                         msgstr,
3332                         (instr(msgstr, ".h ")
3333                          ? " (change .h to .ph maybe?)" : ""),
3334                         (instr(msgstr, ".ph ")
3335                          ? " (did you run h2ph?)" : "")
3336                                                               ));
3337
3338                     for (i = 0; i <= AvFILL(ar); i++) {
3339                         sv_catpvs(msg, " ");
3340                         sv_catsv(msg, *av_fetch(ar, i, TRUE));
3341                     }
3342                     sv_catpvs(msg, ")");
3343                     msgstr = SvPV_nolen_const(msg);
3344                 }
3345             }
3346             DIE(aTHX_ "Can't locate %s", msgstr);
3347         }
3348
3349         RETPUSHUNDEF;
3350     }
3351     else
3352         SETERRNO(0, SS_NORMAL);
3353
3354     /* Assume success here to prevent recursive requirement. */
3355     /* name is never assigned to again, so len is still strlen(name)  */
3356     /* Check whether a hook in @INC has already filled %INC */
3357     if (!hook_sv) {
3358         (void)hv_store(GvHVn(PL_incgv), name, len, newSVpv(CopFILE(&PL_compiling),0),0);
3359     } else {
3360         SV** const svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3361         if (!svp)
3362             (void)hv_store(GvHVn(PL_incgv), name, len, SvREFCNT_inc_simple(hook_sv), 0 );
3363     }
3364
3365     ENTER;
3366     SAVETMPS;
3367     lex_start(sv_2mortal(newSVpvs("")));
3368     SAVEGENERICSV(PL_rsfp_filters);
3369     PL_rsfp_filters = NULL;
3370
3371     PL_rsfp = tryrsfp;
3372     SAVEHINTS();
3373     PL_hints = 0;
3374     SAVECOMPILEWARNINGS();
3375     if (PL_dowarn & G_WARN_ALL_ON)
3376         PL_compiling.cop_warnings = pWARN_ALL ;
3377     else if (PL_dowarn & G_WARN_ALL_OFF)
3378         PL_compiling.cop_warnings = pWARN_NONE ;
3379     else if (PL_taint_warn) {
3380         PL_compiling.cop_warnings
3381             = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize);
3382     }
3383     else
3384         PL_compiling.cop_warnings = pWARN_STD ;
3385
3386     if (filter_sub || filter_cache) {
3387         SV * const datasv = filter_add(S_run_user_filter, NULL);
3388         IoLINES(datasv) = filter_has_file;
3389         IoTOP_GV(datasv) = (GV *)filter_state;
3390         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3391         IoFMT_GV(datasv) = (GV *)filter_cache;
3392     }
3393
3394     /* switch to eval mode */
3395     PUSHBLOCK(cx, CXt_EVAL, SP);
3396     PUSHEVAL(cx, name, NULL);
3397     cx->blk_eval.retop = PL_op->op_next;
3398
3399     SAVECOPLINE(&PL_compiling);
3400     CopLINE_set(&PL_compiling, 0);
3401
3402     PUTBACK;
3403
3404     /* Store and reset encoding. */
3405     encoding = PL_encoding;
3406     PL_encoding = NULL;
3407
3408     op = DOCATCH(doeval(gimme, NULL, NULL, PL_curcop->cop_seq));
3409
3410     /* Restore encoding. */
3411     PL_encoding = encoding;
3412
3413     return op;
3414 }
3415
3416 PP(pp_entereval)
3417 {
3418     dVAR; dSP;
3419     register PERL_CONTEXT *cx;
3420     SV *sv;
3421     const I32 gimme = GIMME_V;
3422     const I32 was = PL_sub_generation;
3423     char tbuf[TYPE_DIGITS(long) + 12];
3424     char *tmpbuf = tbuf;
3425     char *safestr;
3426     STRLEN len;
3427     OP *ret;
3428     CV* runcv;
3429     U32 seq;
3430     HV *saved_hh = NULL;
3431     const char * const fakestr = "_<(eval )";
3432     const int fakelen = 9 + 1;
3433
3434     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3435         saved_hh = (HV*) SvREFCNT_inc(POPs);
3436     }
3437     sv = POPs;
3438
3439     if (!SvPV_nolen_const(sv))
3440         RETPUSHUNDEF;
3441     TAINT_PROPER("eval");
3442
3443     ENTER;
3444     lex_start(sv);
3445     SAVETMPS;
3446
3447     /* switch to eval mode */
3448
3449     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3450         SV * const temp_sv = sv_newmortal();
3451         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3452                        (unsigned long)++PL_evalseq,
3453                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3454         tmpbuf = SvPVX(temp_sv);
3455         len = SvCUR(temp_sv);
3456     }
3457     else
3458         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3459     SAVECOPFILE_FREE(&PL_compiling);
3460     CopFILE_set(&PL_compiling, tmpbuf+2);
3461     SAVECOPLINE(&PL_compiling);
3462     CopLINE_set(&PL_compiling, 1);
3463     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3464        deleting the eval's FILEGV from the stash before gv_check() runs
3465        (i.e. before run-time proper). To work around the coredump that
3466        ensues, we always turn GvMULTI_on for any globals that were
3467        introduced within evals. See force_ident(). GSAR 96-10-12 */
3468     safestr = savepvn(tmpbuf, len);
3469     SAVEDELETE(PL_defstash, safestr, len);
3470     SAVEHINTS();
3471     PL_hints = PL_op->op_targ;
3472     if (saved_hh)
3473         GvHV(PL_hintgv) = saved_hh;
3474     SAVECOMPILEWARNINGS();
3475     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3476     if (PL_compiling.cop_hints_hash) {
3477         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3478     }
3479     PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3480     if (PL_compiling.cop_hints_hash) {
3481         HINTS_REFCNT_LOCK;
3482         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3483         HINTS_REFCNT_UNLOCK;
3484     }
3485     /* special case: an eval '' executed within the DB package gets lexically
3486      * placed in the first non-DB CV rather than the current CV - this
3487      * allows the debugger to execute code, find lexicals etc, in the
3488      * scope of the code being debugged. Passing &seq gets find_runcv
3489      * to do the dirty work for us */
3490     runcv = find_runcv(&seq);
3491
3492     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3493     PUSHEVAL(cx, 0, NULL);
3494     cx->blk_eval.retop = PL_op->op_next;
3495
3496     /* prepare to compile string */
3497
3498     if (PERLDB_LINE && PL_curstash != PL_debstash)
3499         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3500     PUTBACK;
3501     ret = doeval(gimme, NULL, runcv, seq);
3502     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3503         && ret != PL_op->op_next) {     /* Successive compilation. */
3504         /* Copy in anything fake and short. */
3505         my_strlcpy(safestr, fakestr, fakelen);
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;   /* 'This' (and Other to match) to play with C++ */
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_LOOP_NEXTOP_GET(cx);
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 =
4539                     (const char *)memchr(cache_p, '\n', cache_len);
4540                 if (first_nl) {
4541                     take = first_nl + 1 - cache_p;
4542                 }
4543             }
4544             if (take) {
4545                 sv_catpvn(buf_sv, cache_p, take);
4546                 sv_chop(cache, cache_p + take);
4547                 /* Definately not EOF  */
4548                 return 1;
4549             }
4550
4551             sv_catsv(buf_sv, cache);
4552             if (umaxlen) {
4553                 umaxlen -= cache_len;
4554             }
4555             SvOK_off(cache);
4556             read_from_cache = TRUE;
4557         }
4558     }
4559
4560     /* Filter API says that the filter appends to the contents of the buffer.
4561        Usually the buffer is "", so the details don't matter. But if it's not,
4562        then clearly what it contains is already filtered by this filter, so we
4563        don't want to pass it in a second time.
4564        I'm going to use a mortal in case the upstream filter croaks.  */
4565     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4566         ? sv_newmortal() : buf_sv;
4567     SvUPGRADE(upstream, SVt_PV);
4568
4569     if (filter_has_file) {
4570         status = FILTER_READ(idx+1, upstream, 0);
4571     }
4572
4573     if (filter_sub && status >= 0) {
4574         dSP;
4575         int count;
4576
4577         ENTER;
4578         SAVE_DEFSV;
4579         SAVETMPS;
4580         EXTEND(SP, 2);
4581
4582         DEFSV = upstream;
4583         PUSHMARK(SP);
4584         PUSHs(sv_2mortal(newSViv(0)));
4585         if (filter_state) {
4586             PUSHs(filter_state);
4587         }
4588         PUTBACK;
4589         count = call_sv(filter_sub, G_SCALAR);
4590         SPAGAIN;
4591
4592         if (count > 0) {
4593             SV *out = POPs;
4594             if (SvOK(out)) {
4595                 status = SvIV(out);
4596             }
4597         }
4598
4599         PUTBACK;
4600         FREETMPS;
4601         LEAVE;
4602     }
4603
4604     if(SvOK(upstream)) {
4605         got_p = SvPV(upstream, got_len);
4606         if (umaxlen) {
4607             if (got_len > umaxlen) {
4608                 prune_from = got_p + umaxlen;
4609             }
4610         } else {
4611             const char *const first_nl =
4612                 (const char *)memchr(got_p, '\n', got_len);
4613             if (first_nl && first_nl + 1 < got_p + got_len) {
4614                 /* There's a second line here... */
4615                 prune_from = first_nl + 1;
4616             }
4617         }
4618     }
4619     if (prune_from) {
4620         /* Oh. Too long. Stuff some in our cache.  */
4621         STRLEN cached_len = got_p + got_len - prune_from;
4622         SV *cache = (SV *)IoFMT_GV(datasv);
4623
4624         if (!cache) {
4625             IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4626         } else if (SvOK(cache)) {
4627             /* Cache should be empty.  */
4628             assert(!SvCUR(cache));
4629         }
4630
4631         sv_setpvn(cache, prune_from, cached_len);
4632         /* If you ask for block mode, you may well split UTF-8 characters.
4633            "If it breaks, you get to keep both parts"
4634            (Your code is broken if you  don't put them back together again
4635            before something notices.) */
4636         if (SvUTF8(upstream)) {
4637             SvUTF8_on(cache);
4638         }
4639         SvCUR_set(upstream, got_len - cached_len);
4640         /* Can't yet be EOF  */
4641         if (status == 0)
4642             status = 1;
4643     }
4644
4645     /* If they are at EOF but buf_sv has something in it, then they may never
4646        have touched the SV upstream, so it may be undefined.  If we naively
4647        concatenate it then we get a warning about use of uninitialised value.
4648     */
4649     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4650         sv_catsv(buf_sv, upstream);
4651     }
4652
4653     if (status <= 0) {
4654         IoLINES(datasv) = 0;
4655         SvREFCNT_dec(IoFMT_GV(datasv));
4656         if (filter_state) {
4657             SvREFCNT_dec(filter_state);
4658             IoTOP_GV(datasv) = NULL;
4659         }
4660         if (filter_sub) {
4661             SvREFCNT_dec(filter_sub);
4662             IoBOTTOM_GV(datasv) = NULL;
4663         }
4664         filter_del(S_run_user_filter);
4665     }
4666     if (status == 0 && read_from_cache) {
4667         /* If we read some data from the cache (and by getting here it implies
4668            that we emptied the cache) then we aren't yet at EOF, and mustn't
4669            report that to our caller.  */
4670         return 1;
4671     }
4672     return status;
4673 }
4674
4675 /* perhaps someone can come up with a better name for
4676    this?  it is not really "absolute", per se ... */
4677 static bool
4678 S_path_is_absolute(const char *name)
4679 {
4680     if (PERL_FILE_IS_ABSOLUTE(name)
4681 #ifdef MACOS_TRADITIONAL
4682         || (*name == ':')
4683 #else
4684         || (*name == '.' && (name[1] == '/' ||
4685                              (name[1] == '.' && name[2] == '/')))
4686 #endif
4687          )
4688     {
4689         return TRUE;
4690     }
4691     else
4692         return FALSE;
4693 }
4694
4695 /*
4696  * Local variables:
4697  * c-indentation-style: bsd
4698  * c-basic-offset: 4
4699  * indent-tabs-mode: t
4700  * End:
4701  *
4702  * ex: set ts=8 sts=4 sw=4 noet:
4703  */