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