pp_ctl.c

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