pp_ctl.c

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