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(0);
3213             sv_upgrade(namesv, SVt_PV);
3214             for (i = 0; i <= AvFILL(ar); i++) {
3215                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3216
3217                 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3218                     mg_get(dirsv);
3219                 if (SvROK(dirsv)) {
3220                     int count;
3221                     SV **svp;
3222                     SV *loader = dirsv;
3223
3224                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3225                         && !sv_isobject(loader))
3226                     {
3227                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3228                     }
3229
3230                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3231                                    PTR2UV(SvRV(dirsv)), name);
3232                     tryname = SvPVX_const(namesv);
3233                     tryrsfp = NULL;
3234
3235                     ENTER;
3236                     SAVETMPS;
3237                     EXTEND(SP, 2);
3238
3239                     PUSHMARK(SP);
3240                     PUSHs(dirsv);
3241                     PUSHs(sv);
3242                     PUTBACK;
3243                     if (sv_isobject(loader))
3244                         count = call_method("INC", G_ARRAY);
3245                     else
3246                         count = call_sv(loader, G_ARRAY);
3247                     SPAGAIN;
3248
3249                     /* Adjust file name if the hook has set an %INC entry */
3250                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3251                     if (svp)
3252                         tryname = SvPVX_const(*svp);
3253
3254                     if (count > 0) {
3255                         int i = 0;
3256                         SV *arg;
3257
3258                         SP -= count - 1;
3259                         arg = SP[i++];
3260
3261                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3262                             && !isGV_with_GP(SvRV(arg))) {
3263                             filter_cache = SvRV(arg);
3264                             SvREFCNT_inc_simple_void_NN(filter_cache);
3265
3266                             if (i < count) {
3267                                 arg = SP[i++];
3268                             }
3269                         }
3270
3271                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3272                             arg = SvRV(arg);
3273                         }
3274
3275                         if (SvTYPE(arg) == SVt_PVGV) {
3276                             IO * const io = GvIO((GV *)arg);
3277
3278                             ++filter_has_file;
3279
3280                             if (io) {
3281                                 tryrsfp = IoIFP(io);
3282                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3283                                     PerlIO_close(IoOFP(io));
3284                                 }
3285                                 IoIFP(io) = NULL;
3286                                 IoOFP(io) = NULL;
3287                             }
3288
3289                             if (i < count) {
3290                                 arg = SP[i++];
3291                             }
3292                         }
3293
3294                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3295                             filter_sub = arg;
3296                             SvREFCNT_inc_simple_void_NN(filter_sub);
3297
3298                             if (i < count) {
3299                                 filter_state = SP[i];
3300                                 SvREFCNT_inc_simple_void(filter_state);
3301                             }
3302                         }
3303
3304                         if (!tryrsfp && (filter_cache || filter_sub)) {
3305                             tryrsfp = PerlIO_open(BIT_BUCKET,
3306                                                   PERL_SCRIPT_MODE);
3307                         }
3308                         SP--;
3309                     }
3310
3311                     PUTBACK;
3312                     FREETMPS;
3313                     LEAVE;
3314
3315                     if (tryrsfp) {
3316                         hook_sv = dirsv;
3317                         break;
3318                     }
3319
3320                     filter_has_file = 0;
3321                     if (filter_cache) {
3322                         SvREFCNT_dec(filter_cache);
3323                         filter_cache = NULL;
3324                     }
3325                     if (filter_state) {
3326                         SvREFCNT_dec(filter_state);
3327                         filter_state = NULL;
3328                     }
3329                     if (filter_sub) {
3330                         SvREFCNT_dec(filter_sub);
3331                         filter_sub = NULL;
3332                     }
3333                 }
3334                 else {
3335                   if (!path_is_absolute(name)
3336 #ifdef MACOS_TRADITIONAL
3337                         /* We consider paths of the form :a:b ambiguous and interpret them first
3338                            as global then as local
3339                         */
3340                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3341 #endif
3342                   ) {
3343                     const char *dir;
3344                     STRLEN dirlen;
3345
3346                     if (SvOK(dirsv)) {
3347                         dir = SvPV_const(dirsv, dirlen);
3348                     } else {
3349                         dir = "";
3350                         dirlen = 0;
3351                     }
3352
3353 #ifdef MACOS_TRADITIONAL
3354                     char buf1[256];
3355                     char buf2[256];
3356
3357                     MacPerl_CanonDir(name, buf2, 1);
3358                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3359 #else
3360 #  ifdef VMS
3361                     char *unixdir;
3362                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3363                         continue;
3364                     sv_setpv(namesv, unixdir);
3365                     sv_catpv(namesv, unixname);
3366 #  else
3367 #    ifdef __SYMBIAN32__
3368                     if (PL_origfilename[0] &&
3369                         PL_origfilename[1] == ':' &&
3370                         !(dir[0] && dir[1] == ':'))
3371                         Perl_sv_setpvf(aTHX_ namesv,
3372                                        "%c:%s\\%s",
3373                                        PL_origfilename[0],
3374                                        dir, name);
3375                     else
3376                         Perl_sv_setpvf(aTHX_ namesv,
3377                                        "%s\\%s",
3378                                        dir, name);
3379 #    else
3380                     /* The equivalent of
3381                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3382                        but without the need to parse the format string, or
3383                        call strlen on either pointer, and with the correct
3384                        allocation up front.  */
3385                     {
3386                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3387
3388                         memcpy(tmp, dir, dirlen);
3389                         tmp +=dirlen;
3390                         *tmp++ = '/';
3391                         /* name came from an SV, so it will have a '\0' at the
3392                            end that we can copy as part of this memcpy().  */
3393                         memcpy(tmp, name, len + 1);
3394
3395                         SvCUR_set(namesv, dirlen + len + 1);
3396
3397                         /* Don't even actually have to turn SvPOK_on() as we
3398                            access it directly with SvPVX() below.  */
3399                     }
3400 #    endif
3401 #  endif
3402 #endif
3403                     TAINT_PROPER("require");
3404                     tryname = SvPVX_const(namesv);
3405                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3406                     if (tryrsfp) {
3407                         if (tryname[0] == '.' && tryname[1] == '/')
3408                             tryname += 2;
3409                         break;
3410                     }
3411                     else if (errno == EMFILE)
3412                         /* no point in trying other paths if out of handles */
3413                         break;
3414                   }
3415                 }
3416             }
3417         }
3418     }
3419     SAVECOPFILE_FREE(&PL_compiling);
3420     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3421     SvREFCNT_dec(namesv);
3422     if (!tryrsfp) {
3423         if (PL_op->op_type == OP_REQUIRE) {
3424             const char *msgstr = name;
3425             if(errno == EMFILE) {
3426                 SV * const msg
3427                     = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
3428                                                Strerror(errno)));
3429                 msgstr = SvPV_nolen_const(msg);
3430             } else {
3431                 if (namesv) {                   /* did we lookup @INC? */
3432                     AV * const ar = GvAVn(PL_incgv);
3433                     I32 i;
3434                     SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3435                         "%s in @INC%s%s (@INC contains:",
3436                         msgstr,
3437                         (instr(msgstr, ".h ")
3438                          ? " (change .h to .ph maybe?)" : ""),
3439                         (instr(msgstr, ".ph ")
3440                          ? " (did you run h2ph?)" : "")
3441                                                               ));
3442
3443                     for (i = 0; i <= AvFILL(ar); i++) {
3444                         sv_catpvs(msg, " ");
3445                         sv_catsv(msg, *av_fetch(ar, i, TRUE));
3446                     }
3447                     sv_catpvs(msg, ")");
3448                     msgstr = SvPV_nolen_const(msg);
3449                 }
3450             }
3451             DIE(aTHX_ "Can't locate %s", msgstr);
3452         }
3453
3454         RETPUSHUNDEF;
3455     }
3456     else
3457         SETERRNO(0, SS_NORMAL);
3458
3459     /* Assume success here to prevent recursive requirement. */
3460     /* name is never assigned to again, so len is still strlen(name)  */
3461     /* Check whether a hook in @INC has already filled %INC */
3462     if (!hook_sv) {
3463         (void)hv_store(GvHVn(PL_incgv),
3464                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3465     } else {
3466         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3467         if (!svp)
3468             (void)hv_store(GvHVn(PL_incgv),
3469                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3470     }
3471
3472     ENTER;
3473     SAVETMPS;
3474     lex_start(NULL, tryrsfp, TRUE);
3475
3476     SAVEHINTS();
3477     PL_hints = 0;
3478     SAVECOMPILEWARNINGS();
3479     if (PL_dowarn & G_WARN_ALL_ON)
3480         PL_compiling.cop_warnings = pWARN_ALL ;
3481     else if (PL_dowarn & G_WARN_ALL_OFF)
3482         PL_compiling.cop_warnings = pWARN_NONE ;
3483     else
3484         PL_compiling.cop_warnings = pWARN_STD ;
3485
3486     if (filter_sub || filter_cache) {
3487         SV * const datasv = filter_add(S_run_user_filter, NULL);
3488         IoLINES(datasv) = filter_has_file;
3489         IoTOP_GV(datasv) = (GV *)filter_state;
3490         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3491         IoFMT_GV(datasv) = (GV *)filter_cache;
3492     }
3493
3494     /* switch to eval mode */
3495     PUSHBLOCK(cx, CXt_EVAL, SP);
3496     PUSHEVAL(cx, name, NULL);
3497     cx->blk_eval.retop = PL_op->op_next;
3498
3499     SAVECOPLINE(&PL_compiling);
3500     CopLINE_set(&PL_compiling, 0);
3501
3502     PUTBACK;
3503
3504     /* Store and reset encoding. */
3505     encoding = PL_encoding;
3506     PL_encoding = NULL;
3507
3508     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3509         op = DOCATCH(PL_eval_start);
3510     else
3511         op = PL_op->op_next;
3512
3513     /* Restore encoding. */
3514     PL_encoding = encoding;
3515
3516     return op;
3517 }
3518
3519 PP(pp_entereval)
3520 {
3521     dVAR; dSP;
3522     register PERL_CONTEXT *cx;
3523     SV *sv;
3524     const I32 gimme = GIMME_V;
3525     const I32 was = PL_sub_generation;
3526     char tbuf[TYPE_DIGITS(long) + 12];
3527     char *tmpbuf = tbuf;
3528     char *safestr;
3529     STRLEN len;
3530     bool ok;
3531     CV* runcv;
3532     U32 seq;
3533     HV *saved_hh = NULL;
3534     const char * const fakestr = "_<(eval )";
3535     const int fakelen = 9 + 1;
3536
3537     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3538         saved_hh = (HV*) SvREFCNT_inc(POPs);
3539     }
3540     sv = POPs;
3541
3542     TAINT_IF(SvTAINTED(sv));
3543     TAINT_PROPER("eval");
3544
3545     ENTER;
3546     lex_start(sv, NULL, FALSE);
3547     SAVETMPS;
3548
3549     /* switch to eval mode */
3550
3551     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3552         SV * const temp_sv = sv_newmortal();
3553         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3554                        (unsigned long)++PL_evalseq,
3555                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3556         tmpbuf = SvPVX(temp_sv);
3557         len = SvCUR(temp_sv);
3558     }
3559     else
3560         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3561     SAVECOPFILE_FREE(&PL_compiling);
3562     CopFILE_set(&PL_compiling, tmpbuf+2);
3563     SAVECOPLINE(&PL_compiling);
3564     CopLINE_set(&PL_compiling, 1);
3565     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3566        deleting the eval's FILEGV from the stash before gv_check() runs
3567        (i.e. before run-time proper). To work around the coredump that
3568        ensues, we always turn GvMULTI_on for any globals that were
3569        introduced within evals. See force_ident(). GSAR 96-10-12 */
3570     safestr = savepvn(tmpbuf, len);
3571     SAVEDELETE(PL_defstash, safestr, len);
3572     SAVEHINTS();
3573     PL_hints = PL_op->op_targ;
3574     if (saved_hh)
3575         GvHV(PL_hintgv) = saved_hh;
3576     SAVECOMPILEWARNINGS();
3577     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3578     if (PL_compiling.cop_hints_hash) {
3579         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3580     }
3581     PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3582     if (PL_compiling.cop_hints_hash) {
3583         HINTS_REFCNT_LOCK;
3584         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3585         HINTS_REFCNT_UNLOCK;
3586     }
3587     /* special case: an eval '' executed within the DB package gets lexically
3588      * placed in the first non-DB CV rather than the current CV - this
3589      * allows the debugger to execute code, find lexicals etc, in the
3590      * scope of the code being debugged. Passing &seq gets find_runcv
3591      * to do the dirty work for us */
3592     runcv = find_runcv(&seq);
3593
3594     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3595     PUSHEVAL(cx, 0, NULL);
3596     cx->blk_eval.retop = PL_op->op_next;
3597
3598     /* prepare to compile string */
3599
3600     if (PERLDB_LINE && PL_curstash != PL_debstash)
3601         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3602     PUTBACK;
3603     ok = doeval(gimme, NULL, runcv, seq);
3604     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3605         && ok) {
3606         /* Copy in anything fake and short. */
3607         my_strlcpy(safestr, fakestr, fakelen);
3608     }
3609     return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3610 }
3611
3612 PP(pp_leaveeval)
3613 {
3614     dVAR; dSP;
3615     register SV **mark;
3616     SV **newsp;
3617     PMOP *newpm;
3618     I32 gimme;
3619     register PERL_CONTEXT *cx;
3620     OP *retop;
3621     const U8 save_flags = PL_op -> op_flags;
3622     I32 optype;
3623
3624     POPBLOCK(cx,newpm);
3625     POPEVAL(cx);
3626     retop = cx->blk_eval.retop;
3627
3628     TAINT_NOT;
3629     if (gimme == G_VOID)
3630         MARK = newsp;
3631     else if (gimme == G_SCALAR) {
3632         MARK = newsp + 1;
3633         if (MARK <= SP) {
3634             if (SvFLAGS(TOPs) & SVs_TEMP)
3635                 *MARK = TOPs;
3636             else
3637                 *MARK = sv_mortalcopy(TOPs);
3638         }
3639         else {
3640             MEXTEND(mark,0);
3641             *MARK = &PL_sv_undef;
3642         }
3643         SP = MARK;
3644     }
3645     else {
3646         /* in case LEAVE wipes old return values */
3647         for (mark = newsp + 1; mark <= SP; mark++) {
3648             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3649                 *mark = sv_mortalcopy(*mark);
3650                 TAINT_NOT;      /* Each item is independent */
3651             }
3652         }
3653     }
3654     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3655
3656 #ifdef DEBUGGING
3657     assert(CvDEPTH(PL_compcv) == 1);
3658 #endif
3659     CvDEPTH(PL_compcv) = 0;
3660     lex_end();
3661
3662     if (optype == OP_REQUIRE &&
3663         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3664     {
3665         /* Unassume the success we assumed earlier. */
3666         SV * const nsv = cx->blk_eval.old_namesv;
3667         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3668         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3669         /* die_where() did LEAVE, or we won't be here */
3670     }
3671     else {
3672         LEAVE;
3673         if (!(save_flags & OPf_SPECIAL))
3674             sv_setpvn(ERRSV,"",0);
3675     }
3676
3677     RETURNOP(retop);
3678 }
3679
3680 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3681    close to the related Perl_create_eval_scope.  */
3682 void
3683 Perl_delete_eval_scope(pTHX)
3684 {
3685     SV **newsp;
3686     PMOP *newpm;
3687     I32 gimme;
3688     register PERL_CONTEXT *cx;
3689     I32 optype;
3690
3691     POPBLOCK(cx,newpm);
3692     POPEVAL(cx);
3693     PL_curpm = newpm;
3694     LEAVE;
3695     PERL_UNUSED_VAR(newsp);
3696     PERL_UNUSED_VAR(gimme);
3697     PERL_UNUSED_VAR(optype);
3698 }
3699
3700 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3701    also needed by Perl_fold_constants.  */
3702 PERL_CONTEXT *
3703 Perl_create_eval_scope(pTHX_ U32 flags)
3704 {
3705     PERL_CONTEXT *cx;
3706     const I32 gimme = GIMME_V;
3707
3708     ENTER;
3709     SAVETMPS;
3710
3711     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3712     PUSHEVAL(cx, 0, 0);
3713
3714     PL_in_eval = EVAL_INEVAL;
3715     if (flags & G_KEEPERR)
3716         PL_in_eval |= EVAL_KEEPERR;
3717     else
3718         sv_setpvn(ERRSV,"",0);
3719     if (flags & G_FAKINGEVAL) {
3720         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3721     }
3722     return cx;
3723 }
3724
3725 PP(pp_entertry)
3726 {
3727     dVAR;
3728     PERL_CONTEXT * const cx = create_eval_scope(0);
3729     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3730     return DOCATCH(PL_op->op_next);
3731 }
3732
3733 PP(pp_leavetry)
3734 {
3735     dVAR; dSP;
3736     SV **newsp;
3737     PMOP *newpm;
3738     I32 gimme;
3739     register PERL_CONTEXT *cx;
3740     I32 optype;
3741
3742     POPBLOCK(cx,newpm);
3743     POPEVAL(cx);
3744     PERL_UNUSED_VAR(optype);
3745
3746     TAINT_NOT;
3747     if (gimme == G_VOID)
3748         SP = newsp;
3749     else if (gimme == G_SCALAR) {
3750         register SV **mark;
3751         MARK = newsp + 1;
3752         if (MARK <= SP) {
3753             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3754                 *MARK = TOPs;
3755             else
3756                 *MARK = sv_mortalcopy(TOPs);
3757         }
3758         else {
3759             MEXTEND(mark,0);
3760             *MARK = &PL_sv_undef;
3761         }
3762         SP = MARK;
3763     }
3764     else {
3765         /* in case LEAVE wipes old return values */
3766         register SV **mark;
3767         for (mark = newsp + 1; mark <= SP; mark++) {
3768             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3769                 *mark = sv_mortalcopy(*mark);
3770                 TAINT_NOT;      /* Each item is independent */
3771             }
3772         }
3773     }
3774     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3775
3776     LEAVE;
3777     sv_setpvn(ERRSV,"",0);
3778     RETURN;
3779 }
3780
3781 PP(pp_entergiven)
3782 {
3783     dVAR; dSP;
3784     register PERL_CONTEXT *cx;
3785     const I32 gimme = GIMME_V;
3786
3787     ENTER;
3788     SAVETMPS;
3789
3790     if (PL_op->op_targ == 0) {
3791         SV ** const defsv_p = &GvSV(PL_defgv);
3792         *defsv_p = newSVsv(POPs);
3793         SAVECLEARSV(*defsv_p);
3794     }
3795     else
3796         sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3797
3798     PUSHBLOCK(cx, CXt_GIVEN, SP);
3799     PUSHGIVEN(cx);
3800
3801     RETURN;
3802 }
3803
3804 PP(pp_leavegiven)
3805 {
3806     dVAR; dSP;
3807     register PERL_CONTEXT *cx;
3808     I32 gimme;
3809     SV **newsp;
3810     PMOP *newpm;
3811     PERL_UNUSED_CONTEXT;
3812
3813     POPBLOCK(cx,newpm);
3814     assert(CxTYPE(cx) == CXt_GIVEN);
3815
3816     SP = newsp;
3817     PUTBACK;
3818
3819     PL_curpm = newpm;   /* pop $1 et al */
3820
3821     LEAVE;
3822
3823     return NORMAL;
3824 }
3825
3826 /* Helper routines used by pp_smartmatch */
3827 STATIC PMOP *
3828 S_make_matcher(pTHX_ REGEXP *re)
3829 {
3830     dVAR;
3831     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3832     PM_SETRE(matcher, ReREFCNT_inc(re));
3833
3834     SAVEFREEOP((OP *) matcher);
3835     ENTER; SAVETMPS;
3836     SAVEOP();
3837     return matcher;
3838 }
3839
3840 STATIC bool
3841 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3842 {
3843     dVAR;
3844     dSP;
3845
3846     PL_op = (OP *) matcher;
3847     XPUSHs(sv);
3848     PUTBACK;
3849     (void) pp_match();
3850     SPAGAIN;
3851     return (SvTRUEx(POPs));
3852 }
3853
3854 STATIC void
3855 S_destroy_matcher(pTHX_ PMOP *matcher)
3856 {
3857     dVAR;
3858     PERL_UNUSED_ARG(matcher);
3859     FREETMPS;
3860     LEAVE;
3861 }
3862
3863 /* Do a smart match */
3864 PP(pp_smartmatch)
3865 {
3866     return do_smartmatch(NULL, NULL);
3867 }
3868
3869 /* This version of do_smartmatch() implements the
3870  * table of smart matches that is found in perlsyn.
3871  */
3872 STATIC OP *
3873 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3874 {
3875     dVAR;
3876     dSP;
3877
3878     SV *e = TOPs;       /* e is for 'expression' */
3879     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
3880     SV *This, *Other;   /* 'This' (and Other to match) to play with C++ */
3881     REGEXP *this_regex, *other_regex;
3882
3883 #   define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3884
3885 #   define SM_REF(type) ( \
3886            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3887         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3888
3889 #   define SM_CV_NEP   /* Find a code ref without an empty prototype */ \
3890         ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV)              \
3891             && NOT_EMPTY_PROTO(This) && (Other = e))                    \
3892         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV)            \
3893             && NOT_EMPTY_PROTO(This) && (Other = d)))
3894
3895 #   define SM_REGEX ( \
3896            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP)          \
3897         && (this_regex = (REGEXP*) This)                                \
3898         && (Other = e))                                                 \
3899     ||                                                                  \
3900            (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP)          \
3901         && (this_regex = (REGEXP*) This)                                \
3902         && (Other = d)) )
3903
3904
3905 #   define SM_OTHER_REF(type) \
3906         (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3907
3908 #   define SM_OTHER_REGEX (SvROK(Other)                                 \
3909         && (SvTYPE(SvRV(Other)) == SVt_REGEXP)                          \
3910         && (other_regex = (REGEXP*) SvRV(Other)))
3911
3912
3913 #   define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3914         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3915
3916 #   define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3917         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3918
3919     tryAMAGICbinSET(smart, 0);
3920
3921     SP -= 2;    /* Pop the values */
3922
3923     /* Take care only to invoke mg_get() once for each argument.
3924      * Currently we do this by copying the SV if it's magical. */
3925     if (d) {
3926         if (SvGMAGICAL(d))
3927             d = sv_mortalcopy(d);
3928     }
3929     else
3930         d = &PL_sv_undef;
3931
3932     assert(e);
3933     if (SvGMAGICAL(e))
3934         e = sv_mortalcopy(e);
3935
3936     if (SM_CV_NEP) {
3937         I32 c;
3938
3939         if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3940         {
3941             if (This == SvRV(Other))
3942                 RETPUSHYES;
3943             else
3944                 RETPUSHNO;
3945         }
3946
3947         ENTER;
3948         SAVETMPS;
3949         PUSHMARK(SP);
3950         PUSHs(Other);
3951         PUTBACK;
3952         c = call_sv(This, G_SCALAR);
3953         SPAGAIN;
3954         if (c == 0)
3955             PUSHs(&PL_sv_no);
3956         else if (SvTEMP(TOPs))
3957             SvREFCNT_inc_void(TOPs);
3958         FREETMPS;
3959         LEAVE;
3960         RETURN;
3961     }
3962     else if (SM_REF(PVHV)) {
3963         if (SM_OTHER_REF(PVHV)) {
3964             /* Check that the key-sets are identical */
3965             HE *he;
3966             HV *other_hv = (HV *) SvRV(Other);
3967             bool tied = FALSE;
3968             bool other_tied = FALSE;
3969             U32 this_key_count  = 0,
3970                 other_key_count = 0;
3971
3972             /* Tied hashes don't know how many keys they have. */
3973             if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3974                 tied = TRUE;
3975             }
3976             else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3977                 HV * const temp = other_hv;
3978                 other_hv = (HV *) This;
3979                 This  = (SV *) temp;
3980                 tied = TRUE;
3981             }
3982             if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3983                 other_tied = TRUE;
3984
3985             if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
3986                 RETPUSHNO;
3987
3988             /* The hashes have the same number of keys, so it suffices
3989                to check that one is a subset of the other. */
3990             (void) hv_iterinit((HV *) This);
3991             while ( (he = hv_iternext((HV *) This)) ) {
3992                 I32 key_len;
3993                 char * const key = hv_iterkey(he, &key_len);
3994
3995                 ++ this_key_count;
3996
3997                 if(!hv_exists(other_hv, key, key_len)) {
3998                     (void) hv_iterinit((HV *) This);    /* reset iterator */
3999                     RETPUSHNO;
4000                 }
4001             }
4002
4003             if (other_tied) {
4004                 (void) hv_iterinit(other_hv);
4005                 while ( hv_iternext(other_hv) )
4006                     ++other_key_count;
4007             }
4008             else
4009                 other_key_count = HvUSEDKEYS(other_hv);
4010
4011             if (this_key_count != other_key_count)
4012                 RETPUSHNO;
4013             else
4014                 RETPUSHYES;
4015         }
4016         else if (SM_OTHER_REF(PVAV)) {
4017             AV * const other_av = (AV *) SvRV(Other);
4018             const I32 other_len = av_len(other_av) + 1;
4019             I32 i;
4020
4021             for (i = 0; i < other_len; ++i) {
4022                 SV ** const svp = av_fetch(other_av, i, FALSE);
4023                 char *key;
4024                 STRLEN key_len;
4025
4026                 if (svp) {      /* ??? When can this not happen? */
4027                     key = SvPV(*svp, key_len);
4028                     if (hv_exists((HV *) This, key, key_len))
4029                         RETPUSHYES;
4030                 }
4031             }
4032             RETPUSHNO;
4033         }
4034         else if (SM_OTHER_REGEX) {
4035             PMOP * const matcher = make_matcher(other_regex);
4036             HE *he;
4037
4038             (void) hv_iterinit((HV *) This);
4039             while ( (he = hv_iternext((HV *) This)) ) {
4040                 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4041                     (void) hv_iterinit((HV *) This);
4042                     destroy_matcher(matcher);
4043                     RETPUSHYES;
4044                 }
4045             }
4046             destroy_matcher(matcher);
4047             RETPUSHNO;
4048         }
4049         else {
4050             if (hv_exists_ent((HV *) This, Other, 0))
4051                 RETPUSHYES;
4052             else
4053                 RETPUSHNO;
4054         }
4055     }
4056     else if (SM_REF(PVAV)) {
4057         if (SM_OTHER_REF(PVAV)) {
4058             AV *other_av = (AV *) SvRV(Other);
4059             if (av_len((AV *) This) != av_len(other_av))
4060                 RETPUSHNO;
4061             else {
4062                 I32 i;
4063                 const I32 other_len = av_len(other_av);
4064
4065                 if (NULL == seen_this) {
4066                     seen_this = newHV();
4067                     (void) sv_2mortal((SV *) seen_this);
4068                 }
4069                 if (NULL == seen_other) {
4070                     seen_this = newHV();
4071                     (void) sv_2mortal((SV *) seen_other);
4072                 }
4073                 for(i = 0; i <= other_len; ++i) {
4074                     SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4075                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4076
4077                     if (!this_elem || !other_elem) {
4078                         if (this_elem || other_elem)
4079                             RETPUSHNO;
4080                     }
4081                     else if (SM_SEEN_THIS(*this_elem)
4082                          || SM_SEEN_OTHER(*other_elem))
4083                     {
4084                         if (*this_elem != *other_elem)
4085                             RETPUSHNO;
4086                     }
4087                     else {
4088                         (void)hv_store_ent(seen_this,
4089                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4090                                 &PL_sv_undef, 0);
4091                         (void)hv_store_ent(seen_other,
4092                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4093                                 &PL_sv_undef, 0);
4094                         PUSHs(*this_elem);
4095                         PUSHs(*other_elem);
4096
4097                         PUTBACK;
4098                         (void) do_smartmatch(seen_this, seen_other);
4099                         SPAGAIN;
4100
4101                         if (!SvTRUEx(POPs))
4102                             RETPUSHNO;
4103                     }
4104                 }
4105                 RETPUSHYES;
4106             }
4107         }
4108         else if (SM_OTHER_REGEX) {
4109             PMOP * const matcher = make_matcher(other_regex);
4110             const I32 this_len = av_len((AV *) This);
4111             I32 i;
4112
4113             for(i = 0; i <= this_len; ++i) {
4114                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4115                 if (svp && matcher_matches_sv(matcher, *svp)) {
4116                     destroy_matcher(matcher);
4117                     RETPUSHYES;
4118                 }
4119             }
4120             destroy_matcher(matcher);
4121             RETPUSHNO;
4122         }
4123         else if (SvIOK(Other) || SvNOK(Other)) {
4124             I32 i;
4125
4126             for(i = 0; i <= AvFILL((AV *) This); ++i) {
4127                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4128                 if (!svp)
4129                     continue;
4130
4131                 PUSHs(Other);
4132                 PUSHs(*svp);
4133                 PUTBACK;
4134                 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4135                     (void) pp_i_eq();
4136                 else
4137                     (void) pp_eq();
4138                 SPAGAIN;
4139                 if (SvTRUEx(POPs))
4140                     RETPUSHYES;
4141             }
4142             RETPUSHNO;
4143         }
4144         else if (SvPOK(Other)) {
4145             const I32 this_len = av_len((AV *) This);
4146             I32 i;
4147
4148             for(i = 0; i <= this_len; ++i) {
4149                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4150                 if (!svp)
4151                     continue;
4152
4153                 PUSHs(Other);
4154                 PUSHs(*svp);
4155                 PUTBACK;
4156                 (void) pp_seq();
4157                 SPAGAIN;
4158                 if (SvTRUEx(POPs))
4159                     RETPUSHYES;
4160             }
4161             RETPUSHNO;
4162         }
4163     }
4164     else if (!SvOK(d) || !SvOK(e)) {
4165         if (!SvOK(d) && !SvOK(e))
4166             RETPUSHYES;
4167         else
4168             RETPUSHNO;
4169     }
4170     else if (SM_REGEX) {
4171         PMOP * const matcher = make_matcher(this_regex);
4172
4173         PUTBACK;
4174         PUSHs(matcher_matches_sv(matcher, Other)
4175             ? &PL_sv_yes
4176             : &PL_sv_no);
4177         destroy_matcher(matcher);
4178         RETURN;
4179     }
4180     else if (SM_REF(PVCV)) {
4181         I32 c;
4182         /* This must be a null-prototyped sub, because we
4183            already checked for the other kind. */
4184
4185         ENTER;
4186         SAVETMPS;
4187         PUSHMARK(SP);
4188         PUTBACK;
4189         c = call_sv(This, G_SCALAR);
4190         SPAGAIN;
4191         if (c == 0)
4192             PUSHs(&PL_sv_undef);
4193         else if (SvTEMP(TOPs))
4194             SvREFCNT_inc_void(TOPs);
4195
4196         if (SM_OTHER_REF(PVCV)) {
4197             /* This one has to be null-proto'd too.
4198                Call both of 'em, and compare the results */
4199             PUSHMARK(SP);
4200             c = call_sv(SvRV(Other), G_SCALAR);
4201             SPAGAIN;
4202             if (c == 0)
4203                 PUSHs(&PL_sv_undef);
4204             else if (SvTEMP(TOPs))
4205                 SvREFCNT_inc_void(TOPs);
4206             FREETMPS;
4207             LEAVE;
4208             PUTBACK;
4209             return pp_eq();
4210         }
4211
4212         FREETMPS;
4213         LEAVE;
4214         RETURN;
4215     }
4216     else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4217          ||   ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4218     {
4219         if (SvPOK(Other) && !looks_like_number(Other)) {
4220             /* String comparison */
4221             PUSHs(d); PUSHs(e);
4222             PUTBACK;
4223             return pp_seq();
4224         }
4225         /* Otherwise, numeric comparison */
4226         PUSHs(d); PUSHs(e);
4227         PUTBACK;
4228         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4229             (void) pp_i_eq();
4230         else
4231             (void) pp_eq();
4232         SPAGAIN;
4233         if (SvTRUEx(POPs))
4234             RETPUSHYES;
4235         else
4236             RETPUSHNO;
4237     }
4238
4239     /* As a last resort, use string comparison */
4240     PUSHs(d); PUSHs(e);
4241     PUTBACK;
4242     return pp_seq();
4243 }
4244
4245 PP(pp_enterwhen)
4246 {
4247     dVAR; dSP;
4248     register PERL_CONTEXT *cx;
4249     const I32 gimme = GIMME_V;
4250
4251     /* This is essentially an optimization: if the match
4252        fails, we don't want to push a context and then
4253        pop it again right away, so we skip straight
4254        to the op that follows the leavewhen.
4255     */
4256     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4257         return cLOGOP->op_other->op_next;
4258
4259     ENTER;
4260     SAVETMPS;
4261
4262     PUSHBLOCK(cx, CXt_WHEN, SP);
4263     PUSHWHEN(cx);
4264
4265     RETURN;
4266 }
4267
4268 PP(pp_leavewhen)
4269 {
4270     dVAR; dSP;
4271     register PERL_CONTEXT *cx;
4272     I32 gimme;
4273     SV **newsp;
4274     PMOP *newpm;
4275
4276     POPBLOCK(cx,newpm);
4277     assert(CxTYPE(cx) == CXt_WHEN);
4278
4279     SP = newsp;
4280     PUTBACK;
4281
4282     PL_curpm = newpm;   /* pop $1 et al */
4283
4284     LEAVE;
4285     return NORMAL;
4286 }
4287
4288 PP(pp_continue)
4289 {
4290     dVAR;
4291     I32 cxix;
4292     register PERL_CONTEXT *cx;
4293     I32 inner;
4294
4295     cxix = dopoptowhen(cxstack_ix);
4296     if (cxix < 0)
4297         DIE(aTHX_ "Can't \"continue\" outside a when block");
4298     if (cxix < cxstack_ix)
4299         dounwind(cxix);
4300
4301     /* clear off anything above the scope we're re-entering */
4302     inner = PL_scopestack_ix;
4303     TOPBLOCK(cx);
4304     if (PL_scopestack_ix < inner)
4305         leave_scope(PL_scopestack[PL_scopestack_ix]);
4306     PL_curcop = cx->blk_oldcop;
4307     return cx->blk_givwhen.leave_op;
4308 }
4309
4310 PP(pp_break)
4311 {
4312     dVAR;
4313     I32 cxix;
4314     register PERL_CONTEXT *cx;
4315     I32 inner;
4316
4317     cxix = dopoptogiven(cxstack_ix);
4318     if (cxix < 0) {
4319         if (PL_op->op_flags & OPf_SPECIAL)
4320             DIE(aTHX_ "Can't use when() outside a topicalizer");
4321         else
4322             DIE(aTHX_ "Can't \"break\" outside a given block");
4323     }
4324     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4325         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4326
4327     if (cxix < cxstack_ix)
4328         dounwind(cxix);
4329
4330     /* clear off anything above the scope we're re-entering */
4331     inner = PL_scopestack_ix;
4332     TOPBLOCK(cx);
4333     if (PL_scopestack_ix < inner)
4334         leave_scope(PL_scopestack[PL_scopestack_ix]);
4335     PL_curcop = cx->blk_oldcop;
4336
4337     if (CxFOREACH(cx))
4338         return CX_LOOP_NEXTOP_GET(cx);
4339     else
4340         return cx->blk_givwhen.leave_op;
4341 }
4342
4343 STATIC OP *
4344 S_doparseform(pTHX_ SV *sv)
4345 {
4346     STRLEN len;
4347     register char *s = SvPV_force(sv, len);
4348     register char * const send = s + len;
4349     register char *base = NULL;
4350     register I32 skipspaces = 0;
4351     bool noblank   = FALSE;
4352     bool repeat    = FALSE;
4353     bool postspace = FALSE;
4354     U32 *fops;
4355     register U32 *fpc;
4356     U32 *linepc = NULL;
4357     register I32 arg;
4358     bool ischop;
4359     bool unchopnum = FALSE;
4360     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4361
4362     if (len == 0)
4363         Perl_croak(aTHX_ "Null picture in formline");
4364
4365     /* estimate the buffer size needed */
4366     for (base = s; s <= send; s++) {
4367         if (*s == '\n' || *s == '@' || *s == '^')
4368             maxops += 10;
4369     }
4370     s = base;
4371     base = NULL;
4372
4373     Newx(fops, maxops, U32);
4374     fpc = fops;
4375
4376     if (s < send) {
4377         linepc = fpc;
4378         *fpc++ = FF_LINEMARK;
4379         noblank = repeat = FALSE;
4380         base = s;
4381     }
4382
4383     while (s <= send) {
4384         switch (*s++) {
4385         default:
4386             skipspaces = 0;
4387             continue;
4388
4389         case '~':
4390             if (*s == '~') {
4391                 repeat = TRUE;
4392                 *s = ' ';
4393             }
4394             noblank = TRUE;
4395             s[-1] = ' ';
4396             /* FALL THROUGH */
4397         case ' ': case '\t':
4398             skipspaces++;
4399             continue;
4400         case 0:
4401             if (s < send) {
4402                 skipspaces = 0;
4403                 continue;
4404             } /* else FALL THROUGH */
4405         case '\n':
4406             arg = s - base;
4407             skipspaces++;
4408             arg -= skipspaces;
4409             if (arg) {
4410                 if (postspace)
4411                     *fpc++ = FF_SPACE;
4412                 *fpc++ = FF_LITERAL;
4413                 *fpc++ = (U16)arg;
4414             }
4415             postspace = FALSE;
4416             if (s <= send)
4417                 skipspaces--;
4418             if (skipspaces) {
4419                 *fpc++ = FF_SKIP;
4420                 *fpc++ = (U16)skipspaces;
4421             }
4422             skipspaces = 0;
4423             if (s <= send)
4424                 *fpc++ = FF_NEWLINE;
4425             if (noblank) {
4426                 *fpc++ = FF_BLANK;
4427                 if (repeat)
4428                     arg = fpc - linepc + 1;
4429                 else
4430                     arg = 0;
4431                 *fpc++ = (U16)arg;
4432             }
4433             if (s < send) {
4434                 linepc = fpc;
4435                 *fpc++ = FF_LINEMARK;
4436                 noblank = repeat = FALSE;
4437                 base = s;
4438             }
4439             else
4440                 s++;
4441             continue;
4442
4443         case '@':
4444         case '^':
4445             ischop = s[-1] == '^';
4446
4447             if (postspace) {
4448                 *fpc++ = FF_SPACE;
4449                 postspace = FALSE;
4450             }
4451             arg = (s - base) - 1;
4452             if (arg) {
4453                 *fpc++ = FF_LITERAL;
4454                 *fpc++ = (U16)arg;
4455             }
4456
4457             base = s - 1;
4458             *fpc++ = FF_FETCH;
4459             if (*s == '*') {
4460                 s++;
4461                 *fpc++ = 2;  /* skip the @* or ^* */
4462                 if (ischop) {
4463                     *fpc++ = FF_LINESNGL;
4464                     *fpc++ = FF_CHOP;
4465                 } else
4466                     *fpc++ = FF_LINEGLOB;
4467             }
4468             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4469                 arg = ischop ? 512 : 0;
4470                 base = s - 1;
4471                 while (*s == '#')
4472                     s++;
4473                 if (*s == '.') {
4474                     const char * const f = ++s;
4475                     while (*s == '#')
4476                         s++;
4477                     arg |= 256 + (s - f);
4478                 }
4479                 *fpc++ = s - base;              /* fieldsize for FETCH */
4480                 *fpc++ = FF_DECIMAL;
4481                 *fpc++ = (U16)arg;
4482                 unchopnum |= ! ischop;
4483             }
4484             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4485                 arg = ischop ? 512 : 0;
4486                 base = s - 1;
4487                 s++;                                /* skip the '0' first */
4488                 while (*s == '#')
4489                     s++;
4490                 if (*s == '.') {
4491                     const char * const f = ++s;
4492                     while (*s == '#')
4493                         s++;
4494                     arg |= 256 + (s - f);
4495                 }
4496                 *fpc++ = s - base;                /* fieldsize for FETCH */
4497                 *fpc++ = FF_0DECIMAL;
4498                 *fpc++ = (U16)arg;
4499                 unchopnum |= ! ischop;
4500             }
4501             else {
4502                 I32 prespace = 0;
4503                 bool ismore = FALSE;
4504
4505                 if (*s == '>') {
4506                     while (*++s == '>') ;
4507                     prespace = FF_SPACE;
4508                 }
4509                 else if (*s == '|') {
4510                     while (*++s == '|') ;
4511                     prespace = FF_HALFSPACE;
4512                     postspace = TRUE;
4513                 }
4514                 else {
4515                     if (*s == '<')
4516                         while (*++s == '<') ;
4517                     postspace = TRUE;
4518                 }
4519                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4520                     s += 3;
4521                     ismore = TRUE;
4522                 }
4523                 *fpc++ = s - base;              /* fieldsize for FETCH */
4524
4525                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4526
4527                 if (prespace)
4528                     *fpc++ = (U16)prespace;
4529                 *fpc++ = FF_ITEM;
4530                 if (ismore)
4531                     *fpc++ = FF_MORE;
4532                 if (ischop)
4533                     *fpc++ = FF_CHOP;
4534             }
4535             base = s;
4536             skipspaces = 0;
4537             continue;
4538         }
4539     }
4540     *fpc++ = FF_END;
4541
4542     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4543     arg = fpc - fops;
4544     { /* need to jump to the next word */
4545         int z;
4546         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4547         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4548         s = SvPVX(sv) + SvCUR(sv) + z;
4549     }
4550     Copy(fops, s, arg, U32);
4551     Safefree(fops);
4552     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4553     SvCOMPILED_on(sv);
4554
4555     if (unchopnum && repeat)
4556         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4557     return 0;
4558 }
4559
4560
4561 STATIC bool
4562 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4563 {
4564     /* Can value be printed in fldsize chars, using %*.*f ? */
4565     NV pwr = 1;
4566     NV eps = 0.5;
4567     bool res = FALSE;
4568     int intsize = fldsize - (value < 0 ? 1 : 0);
4569
4570     if (frcsize & 256)
4571         intsize--;
4572     frcsize &= 255;
4573     intsize -= frcsize;
4574
4575     while (intsize--) pwr *= 10.0;
4576     while (frcsize--) eps /= 10.0;
4577
4578     if( value >= 0 ){
4579         if (value + eps >= pwr)
4580             res = TRUE;
4581     } else {
4582         if (value - eps <= -pwr)
4583             res = TRUE;
4584     }
4585     return res;
4586 }
4587
4588 static I32
4589 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4590 {
4591     dVAR;
4592     SV * const datasv = FILTER_DATA(idx);
4593     const int filter_has_file = IoLINES(datasv);
4594     SV * const filter_state = (SV *)IoTOP_GV(datasv);
4595     SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4596     int status = 0;
4597     SV *upstream;
4598     STRLEN got_len;
4599     const char *got_p = NULL;
4600     const char *prune_from = NULL;
4601     bool read_from_cache = FALSE;
4602     STRLEN umaxlen;
4603
4604     assert(maxlen >= 0);
4605     umaxlen = maxlen;
4606
4607     /* I was having segfault trouble under Linux 2.2.5 after a
4608        parse error occured.  (Had to hack around it with a test
4609        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4610        not sure where the trouble is yet.  XXX */
4611
4612     if (IoFMT_GV(datasv)) {
4613         SV *const cache = (SV *)IoFMT_GV(datasv);
4614         if (SvOK(cache)) {
4615             STRLEN cache_len;
4616             const char *cache_p = SvPV(cache, cache_len);
4617             STRLEN take = 0;
4618
4619             if (umaxlen) {
4620                 /* Running in block mode and we have some cached data already.
4621                  */
4622                 if (cache_len >= umaxlen) {
4623                     /* In fact, so much data we don't even need to call
4624                        filter_read.  */
4625                     take = umaxlen;
4626                 }
4627             } else {
4628                 const char *const first_nl =
4629                     (const char *)memchr(cache_p, '\n', cache_len);
4630                 if (first_nl) {
4631                     take = first_nl + 1 - cache_p;
4632                 }
4633             }
4634             if (take) {
4635                 sv_catpvn(buf_sv, cache_p, take);
4636                 sv_chop(cache, cache_p + take);
4637                 /* Definately not EOF  */
4638                 return 1;
4639             }
4640
4641             sv_catsv(buf_sv, cache);
4642             if (umaxlen) {
4643                 umaxlen -= cache_len;
4644             }
4645             SvOK_off(cache);
4646             read_from_cache = TRUE;
4647         }
4648     }
4649
4650     /* Filter API says that the filter appends to the contents of the buffer.
4651        Usually the buffer is "", so the details don't matter. But if it's not,
4652        then clearly what it contains is already filtered by this filter, so we
4653        don't want to pass it in a second time.
4654        I'm going to use a mortal in case the upstream filter croaks.  */
4655     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4656         ? sv_newmortal() : buf_sv;
4657     SvUPGRADE(upstream, SVt_PV);
4658
4659     if (filter_has_file) {
4660         status = FILTER_READ(idx+1, upstream, 0);
4661     }
4662
4663     if (filter_sub && status >= 0) {
4664         dSP;
4665         int count;
4666
4667         ENTER;
4668         SAVE_DEFSV;
4669         SAVETMPS;
4670         EXTEND(SP, 2);
4671
4672         DEFSV = upstream;
4673         PUSHMARK(SP);
4674         mPUSHi(0);
4675         if (filter_state) {
4676             PUSHs(filter_state);
4677         }
4678         PUTBACK;
4679         count = call_sv(filter_sub, G_SCALAR);
4680         SPAGAIN;
4681
4682         if (count > 0) {
4683             SV *out = POPs;
4684             if (SvOK(out)) {
4685                 status = SvIV(out);
4686             }
4687         }
4688
4689         PUTBACK;
4690         FREETMPS;
4691         LEAVE;
4692     }
4693
4694     if(SvOK(upstream)) {
4695         got_p = SvPV(upstream, got_len);
4696         if (umaxlen) {
4697             if (got_len > umaxlen) {
4698                 prune_from = got_p + umaxlen;
4699             }
4700         } else {
4701             const char *const first_nl =
4702                 (const char *)memchr(got_p, '\n', got_len);
4703             if (first_nl && first_nl + 1 < got_p + got_len) {
4704                 /* There's a second line here... */
4705                 prune_from = first_nl + 1;
4706             }
4707         }
4708     }
4709     if (prune_from) {
4710         /* Oh. Too long. Stuff some in our cache.  */
4711         STRLEN cached_len = got_p + got_len - prune_from;
4712         SV *cache = (SV *)IoFMT_GV(datasv);
4713
4714         if (!cache) {
4715             IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4716         } else if (SvOK(cache)) {
4717             /* Cache should be empty.  */
4718             assert(!SvCUR(cache));
4719         }
4720
4721         sv_setpvn(cache, prune_from, cached_len);
4722         /* If you ask for block mode, you may well split UTF-8 characters.
4723            "If it breaks, you get to keep both parts"
4724            (Your code is broken if you  don't put them back together again
4725            before something notices.) */
4726         if (SvUTF8(upstream)) {
4727             SvUTF8_on(cache);
4728         }
4729         SvCUR_set(upstream, got_len - cached_len);
4730         /* Can't yet be EOF  */
4731         if (status == 0)
4732             status = 1;
4733     }
4734
4735     /* If they are at EOF but buf_sv has something in it, then they may never
4736        have touched the SV upstream, so it may be undefined.  If we naively
4737        concatenate it then we get a warning about use of uninitialised value.
4738     */
4739     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4740         sv_catsv(buf_sv, upstream);
4741     }
4742
4743     if (status <= 0) {
4744         IoLINES(datasv) = 0;
4745         SvREFCNT_dec(IoFMT_GV(datasv));
4746         if (filter_state) {
4747             SvREFCNT_dec(filter_state);
4748             IoTOP_GV(datasv) = NULL;
4749         }
4750         if (filter_sub) {
4751             SvREFCNT_dec(filter_sub);
4752             IoBOTTOM_GV(datasv) = NULL;
4753         }
4754         filter_del(S_run_user_filter);
4755     }
4756     if (status == 0 && read_from_cache) {
4757         /* If we read some data from the cache (and by getting here it implies
4758            that we emptied the cache) then we aren't yet at EOF, and mustn't
4759            report that to our caller.  */
4760         return 1;
4761     }
4762     return status;
4763 }
4764
4765 /* perhaps someone can come up with a better name for
4766    this?  it is not really "absolute", per se ... */
4767 static bool
4768 S_path_is_absolute(const char *name)
4769 {
4770     if (PERL_FILE_IS_ABSOLUTE(name)
4771 #ifdef MACOS_TRADITIONAL
4772         || (*name == ':')
4773 #else
4774         || (*name == '.' && (name[1] == '/' ||
4775                              (name[1] == '.' && name[2] == '/')))
4776 #endif
4777          )
4778     {
4779         return TRUE;
4780     }
4781     else
4782         return FALSE;
4783 }
4784
4785 /*
4786  * Local variables:
4787  * c-indentation-style: bsd
4788  * c-basic-offset: 4
4789  * indent-tabs-mode: t
4790  * End:
4791  *
4792  * ex: set ts=8 sts=4 sw=4 noet:
4793  */