pp_ctl.c

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