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