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