pp_ctl.c

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