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