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_LAZYIV:
1260         case CXt_LOOP_LAZYSV:
1261         case CXt_LOOP_FOR:
1262         case CXt_LOOP_PLAIN:
1263             if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1264                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1265                         (long)i, CxLABEL(cx)));
1266                 continue;
1267             }
1268             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1269             return i;
1270         }
1271     }
1272     return i;
1273 }
1274
1275
1276
1277 I32
1278 Perl_dowantarray(pTHX)
1279 {
1280     dVAR;
1281     const I32 gimme = block_gimme();
1282     return (gimme == G_VOID) ? G_SCALAR : gimme;
1283 }
1284
1285 I32
1286 Perl_block_gimme(pTHX)
1287 {
1288     dVAR;
1289     const I32 cxix = dopoptosub(cxstack_ix);
1290     if (cxix < 0)
1291         return G_VOID;
1292
1293     switch (cxstack[cxix].blk_gimme) {
1294     case G_VOID:
1295         return G_VOID;
1296     case G_SCALAR:
1297         return G_SCALAR;
1298     case G_ARRAY:
1299         return G_ARRAY;
1300     default:
1301         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1302         /* NOTREACHED */
1303         return 0;
1304     }
1305 }
1306
1307 I32
1308 Perl_is_lvalue_sub(pTHX)
1309 {
1310     dVAR;
1311     const I32 cxix = dopoptosub(cxstack_ix);
1312     assert(cxix >= 0);  /* We should only be called from inside subs */
1313
1314     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1315         return CxLVAL(cxstack + cxix);
1316     else
1317         return 0;
1318 }
1319
1320 STATIC I32
1321 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1322 {
1323     dVAR;
1324     I32 i;
1325     for (i = startingblock; i >= 0; i--) {
1326         register const PERL_CONTEXT * const cx = &cxstk[i];
1327         switch (CxTYPE(cx)) {
1328         default:
1329             continue;
1330         case CXt_EVAL:
1331         case CXt_SUB:
1332         case CXt_FORMAT:
1333             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1334             return i;
1335         }
1336     }
1337     return i;
1338 }
1339
1340 STATIC I32
1341 S_dopoptoeval(pTHX_ I32 startingblock)
1342 {
1343     dVAR;
1344     I32 i;
1345     for (i = startingblock; i >= 0; i--) {
1346         register const PERL_CONTEXT *cx = &cxstack[i];
1347         switch (CxTYPE(cx)) {
1348         default:
1349             continue;
1350         case CXt_EVAL:
1351             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1352             return i;
1353         }
1354     }
1355     return i;
1356 }
1357
1358 STATIC I32
1359 S_dopoptoloop(pTHX_ I32 startingblock)
1360 {
1361     dVAR;
1362     I32 i;
1363     for (i = startingblock; i >= 0; i--) {
1364         register const PERL_CONTEXT * const cx = &cxstack[i];
1365         switch (CxTYPE(cx)) {
1366         case CXt_SUBST:
1367         case CXt_SUB:
1368         case CXt_FORMAT:
1369         case CXt_EVAL:
1370         case CXt_NULL:
1371             if (ckWARN(WARN_EXITING))
1372                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1373                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1374             if ((CxTYPE(cx)) == CXt_NULL)
1375                 return -1;
1376             break;
1377         case CXt_LOOP_LAZYIV:
1378         case CXt_LOOP_LAZYSV:
1379         case CXt_LOOP_FOR:
1380         case CXt_LOOP_PLAIN:
1381             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1382             return i;
1383         }
1384     }
1385     return i;
1386 }
1387
1388 STATIC I32
1389 S_dopoptogiven(pTHX_ I32 startingblock)
1390 {
1391     dVAR;
1392     I32 i;
1393     for (i = startingblock; i >= 0; i--) {
1394         register const PERL_CONTEXT *cx = &cxstack[i];
1395         switch (CxTYPE(cx)) {
1396         default:
1397             continue;
1398         case CXt_GIVEN:
1399             DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1400             return i;
1401         case CXt_LOOP_PLAIN:
1402             assert(!CxFOREACHDEF(cx));
1403             break;
1404         case CXt_LOOP_LAZYIV:
1405         case CXt_LOOP_LAZYSV:
1406         case CXt_LOOP_FOR:
1407             if (CxFOREACHDEF(cx)) {
1408                 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1409                 return i;
1410             }
1411         }
1412     }
1413     return i;
1414 }
1415
1416 STATIC I32
1417 S_dopoptowhen(pTHX_ I32 startingblock)
1418 {
1419     dVAR;
1420     I32 i;
1421     for (i = startingblock; i >= 0; i--) {
1422         register const PERL_CONTEXT *cx = &cxstack[i];
1423         switch (CxTYPE(cx)) {
1424         default:
1425             continue;
1426         case CXt_WHEN:
1427             DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1428             return i;
1429         }
1430     }
1431     return i;
1432 }
1433
1434 void
1435 Perl_dounwind(pTHX_ I32 cxix)
1436 {
1437     dVAR;
1438     I32 optype;
1439
1440     while (cxstack_ix > cxix) {
1441         SV *sv;
1442         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1443         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1444                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1445         /* Note: we don't need to restore the base context info till the end. */
1446         switch (CxTYPE(cx)) {
1447         case CXt_SUBST:
1448             POPSUBST(cx);
1449             continue;  /* not break */
1450         case CXt_SUB:
1451             POPSUB(cx,sv);
1452             LEAVESUB(sv);
1453             break;
1454         case CXt_EVAL:
1455             POPEVAL(cx);
1456             break;
1457         case CXt_LOOP_LAZYIV:
1458         case CXt_LOOP_LAZYSV:
1459         case CXt_LOOP_FOR:
1460         case CXt_LOOP_PLAIN:
1461             POPLOOP(cx);
1462             break;
1463         case CXt_NULL:
1464             break;
1465         case CXt_FORMAT:
1466             POPFORMAT(cx);
1467             break;
1468         }
1469         cxstack_ix--;
1470     }
1471     PERL_UNUSED_VAR(optype);
1472 }
1473
1474 void
1475 Perl_qerror(pTHX_ SV *err)
1476 {
1477     dVAR;
1478     if (PL_in_eval)
1479         sv_catsv(ERRSV, err);
1480     else if (PL_errors)
1481         sv_catsv(PL_errors, err);
1482     else
1483         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1484     if (PL_parser)
1485         ++PL_parser->error_count;
1486 }
1487
1488 OP *
1489 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1490 {
1491     dVAR;
1492
1493     if (PL_in_eval) {
1494         I32 cxix;
1495         I32 gimme;
1496
1497         if (message) {
1498             if (PL_in_eval & EVAL_KEEPERR) {
1499                 static const char prefix[] = "\t(in cleanup) ";
1500                 SV * const err = ERRSV;
1501                 const char *e = NULL;
1502                 if (!SvPOK(err))
1503                     sv_setpvn(err,"",0);
1504                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1505                     STRLEN len;
1506                     e = SvPV_const(err, len);
1507                     e += len - msglen;
1508                     if (*e != *message || strNE(e,message))
1509                         e = NULL;
1510                 }
1511                 if (!e) {
1512                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1513                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1514                     sv_catpvn(err, message, msglen);
1515                     if (ckWARN(WARN_MISC)) {
1516                         const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1517                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1518                     }
1519                 }
1520             }
1521             else {
1522                 sv_setpvn(ERRSV, message, msglen);
1523             }
1524         }
1525
1526         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1527                && PL_curstackinfo->si_prev)
1528         {
1529             dounwind(-1);
1530             POPSTACK;
1531         }
1532
1533         if (cxix >= 0) {
1534             I32 optype;
1535             register PERL_CONTEXT *cx;
1536             SV **newsp;
1537
1538             if (cxix < cxstack_ix)
1539                 dounwind(cxix);
1540
1541             POPBLOCK(cx,PL_curpm);
1542             if (CxTYPE(cx) != CXt_EVAL) {
1543                 if (!message)
1544                     message = SvPVx_const(ERRSV, msglen);
1545                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1546                 PerlIO_write(Perl_error_log, message, msglen);
1547                 my_exit(1);
1548             }
1549             POPEVAL(cx);
1550
1551             if (gimme == G_SCALAR)
1552                 *++newsp = &PL_sv_undef;
1553             PL_stack_sp = newsp;
1554
1555             LEAVE;
1556
1557             /* LEAVE could clobber PL_curcop (see save_re_context())
1558              * XXX it might be better to find a way to avoid messing with
1559              * PL_curcop in save_re_context() instead, but this is a more
1560              * minimal fix --GSAR */
1561             PL_curcop = cx->blk_oldcop;
1562
1563             if (optype == OP_REQUIRE) {
1564                 const char* const msg = SvPVx_nolen_const(ERRSV);
1565                 SV * const nsv = cx->blk_eval.old_namesv;
1566                 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1567                                &PL_sv_undef, 0);
1568                 DIE(aTHX_ "%sCompilation failed in require",
1569                     *msg ? msg : "Unknown error\n");
1570             }
1571             assert(CxTYPE(cx) == CXt_EVAL);
1572             return cx->blk_eval.retop;
1573         }
1574     }
1575     if (!message)
1576         message = SvPVx_const(ERRSV, msglen);
1577
1578     write_to_stderr(message, msglen);
1579     my_failure_exit();
1580     /* NOTREACHED */
1581     return 0;
1582 }
1583
1584 PP(pp_xor)
1585 {
1586     dVAR; dSP; dPOPTOPssrl;
1587     if (SvTRUE(left) != SvTRUE(right))
1588         RETSETYES;
1589     else
1590         RETSETNO;
1591 }
1592
1593 PP(pp_caller)
1594 {
1595     dVAR;
1596     dSP;
1597     register I32 cxix = dopoptosub(cxstack_ix);
1598     register const PERL_CONTEXT *cx;
1599     register const PERL_CONTEXT *ccstack = cxstack;
1600     const PERL_SI *top_si = PL_curstackinfo;
1601     I32 gimme;
1602     const char *stashname;
1603     I32 count = 0;
1604
1605     if (MAXARG)
1606         count = POPi;
1607
1608     for (;;) {
1609         /* we may be in a higher stacklevel, so dig down deeper */
1610         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1611             top_si = top_si->si_prev;
1612             ccstack = top_si->si_cxstack;
1613             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1614         }
1615         if (cxix < 0) {
1616             if (GIMME != G_ARRAY) {
1617                 EXTEND(SP, 1);
1618                 RETPUSHUNDEF;
1619             }
1620             RETURN;
1621         }
1622         /* caller() should not report the automatic calls to &DB::sub */
1623         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1624                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1625             count++;
1626         if (!count--)
1627             break;
1628         cxix = dopoptosub_at(ccstack, cxix - 1);
1629     }
1630
1631     cx = &ccstack[cxix];
1632     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1633         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1634         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1635            field below is defined for any cx. */
1636         /* caller() should not report the automatic calls to &DB::sub */
1637         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1638             cx = &ccstack[dbcxix];
1639     }
1640
1641     stashname = CopSTASHPV(cx->blk_oldcop);
1642     if (GIMME != G_ARRAY) {
1643         EXTEND(SP, 1);
1644         if (!stashname)
1645             PUSHs(&PL_sv_undef);
1646         else {
1647             dTARGET;
1648             sv_setpv(TARG, stashname);
1649             PUSHs(TARG);
1650         }
1651         RETURN;
1652     }
1653
1654     EXTEND(SP, 11);
1655
1656     if (!stashname)
1657         PUSHs(&PL_sv_undef);
1658     else
1659         mPUSHs(newSVpv(stashname, 0));
1660     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1661     mPUSHi((I32)CopLINE(cx->blk_oldcop));
1662     if (!MAXARG)
1663         RETURN;
1664     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1665         GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1666         /* So is ccstack[dbcxix]. */
1667         if (isGV(cvgv)) {
1668             SV * const sv = newSV(0);
1669             gv_efullname3(sv, cvgv, NULL);
1670             mPUSHs(sv);
1671             PUSHs(boolSV(CxHASARGS(cx)));
1672         }
1673         else {
1674             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1675             PUSHs(boolSV(CxHASARGS(cx)));
1676         }
1677     }
1678     else {
1679         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1680         mPUSHi(0);
1681     }
1682     gimme = (I32)cx->blk_gimme;
1683     if (gimme == G_VOID)
1684         PUSHs(&PL_sv_undef);
1685     else
1686         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1687     if (CxTYPE(cx) == CXt_EVAL) {
1688         /* eval STRING */
1689         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1690             PUSHs(cx->blk_eval.cur_text);
1691             PUSHs(&PL_sv_no);
1692         }
1693         /* require */
1694         else if (cx->blk_eval.old_namesv) {
1695             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1696             PUSHs(&PL_sv_yes);
1697         }
1698         /* eval BLOCK (try blocks have old_namesv == 0) */
1699         else {
1700             PUSHs(&PL_sv_undef);
1701             PUSHs(&PL_sv_undef);
1702         }
1703     }
1704     else {
1705         PUSHs(&PL_sv_undef);
1706         PUSHs(&PL_sv_undef);
1707     }
1708     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1709         && CopSTASH_eq(PL_curcop, PL_debstash))
1710     {
1711         AV * const ary = cx->blk_sub.argarray;
1712         const int off = AvARRAY(ary) - AvALLOC(ary);
1713
1714         if (!PL_dbargs) {
1715             GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1716             PL_dbargs = GvAV(gv_AVadd(tmpgv));
1717             GvMULTI_on(tmpgv);
1718             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1719         }
1720
1721         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1722             av_extend(PL_dbargs, AvFILLp(ary) + off);
1723         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1724         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1725     }
1726     /* XXX only hints propagated via op_private are currently
1727      * visible (others are not easily accessible, since they
1728      * use the global PL_hints) */
1729     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1730     {
1731         SV * mask ;
1732         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1733
1734         if  (old_warnings == pWARN_NONE ||
1735                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1736             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1737         else if (old_warnings == pWARN_ALL ||
1738                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1739             /* Get the bit mask for $warnings::Bits{all}, because
1740              * it could have been extended by warnings::register */
1741             SV **bits_all;
1742             HV * const bits = get_hv("warnings::Bits", FALSE);
1743             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1744                 mask = newSVsv(*bits_all);
1745             }
1746             else {
1747                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1748             }
1749         }
1750         else
1751             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1752         mPUSHs(mask);
1753     }
1754
1755     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1756           sv_2mortal(newRV_noinc(
1757             (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1758                                               cx->blk_oldcop->cop_hints_hash)))
1759           : &PL_sv_undef);
1760     RETURN;
1761 }
1762
1763 PP(pp_reset)
1764 {
1765     dVAR;
1766     dSP;
1767     const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1768     sv_reset(tmps, CopSTASH(PL_curcop));
1769     PUSHs(&PL_sv_yes);
1770     RETURN;
1771 }
1772
1773 /* like pp_nextstate, but used instead when the debugger is active */
1774
1775 PP(pp_dbstate)
1776 {
1777     dVAR;
1778     PL_curcop = (COP*)PL_op;
1779     TAINT_NOT;          /* Each statement is presumed innocent */
1780     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1781     FREETMPS;
1782
1783     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1784             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1785     {
1786         dSP;
1787         register PERL_CONTEXT *cx;
1788         const I32 gimme = G_ARRAY;
1789         U8 hasargs;
1790         GV * const gv = PL_DBgv;
1791         register CV * const cv = GvCV(gv);
1792
1793         if (!cv)
1794             DIE(aTHX_ "No DB::DB routine defined");
1795
1796         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1797             /* don't do recursive DB::DB call */
1798             return NORMAL;
1799
1800         ENTER;
1801         SAVETMPS;
1802
1803         SAVEI32(PL_debug);
1804         SAVESTACK_POS();
1805         PL_debug = 0;
1806         hasargs = 0;
1807         SPAGAIN;
1808
1809         if (CvISXSUB(cv)) {
1810             CvDEPTH(cv)++;
1811             PUSHMARK(SP);
1812             (void)(*CvXSUB(cv))(aTHX_ cv);
1813             CvDEPTH(cv)--;
1814             FREETMPS;
1815             LEAVE;
1816             return NORMAL;
1817         }
1818         else {
1819             PUSHBLOCK(cx, CXt_SUB, SP);
1820             PUSHSUB_DB(cx);
1821             cx->blk_sub.retop = PL_op->op_next;
1822             CvDEPTH(cv)++;
1823             SAVECOMPPAD();
1824             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1825             RETURNOP(CvSTART(cv));
1826         }
1827     }
1828     else
1829         return NORMAL;
1830 }
1831
1832 PP(pp_enteriter)
1833 {
1834     dVAR; dSP; dMARK;
1835     register PERL_CONTEXT *cx;
1836     const I32 gimme = GIMME_V;
1837     SV **svp;
1838     U8 cxtype = CXt_LOOP_FOR;
1839 #ifdef USE_ITHREADS
1840     void *iterdata;
1841 #endif
1842
1843     ENTER;
1844     SAVETMPS;
1845
1846     if (PL_op->op_targ) {
1847         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1848             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1849             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1850                     SVs_PADSTALE, SVs_PADSTALE);
1851         }
1852 #ifndef USE_ITHREADS
1853         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1854         SAVESPTR(*svp);
1855 #else
1856         SAVEPADSV(PL_op->op_targ);
1857         iterdata = INT2PTR(void*, PL_op->op_targ);
1858         cxtype |= CXp_PADVAR;
1859 #endif
1860     }
1861     else {
1862         GV * const gv = (GV*)POPs;
1863         svp = &GvSV(gv);                        /* symbol table variable */
1864         SAVEGENERICSV(*svp);
1865         *svp = newSV(0);
1866 #ifdef USE_ITHREADS
1867         iterdata = (void*)gv;
1868 #endif
1869     }
1870
1871     if (PL_op->op_private & OPpITER_DEF)
1872         cxtype |= CXp_FOR_DEF;
1873
1874     ENTER;
1875
1876     PUSHBLOCK(cx, cxtype, SP);
1877 #ifdef USE_ITHREADS
1878     PUSHLOOP_FOR(cx, iterdata, MARK);
1879 #else
1880     PUSHLOOP_FOR(cx, svp, MARK);
1881 #endif
1882     if (PL_op->op_flags & OPf_STACKED) {
1883         SV *maybe_ary = POPs;
1884         if (SvTYPE(maybe_ary) != SVt_PVAV) {
1885             dPOPss;
1886             SV * const right = maybe_ary;
1887             SvGETMAGIC(sv);
1888             SvGETMAGIC(right);
1889             if (RANGE_IS_NUMERIC(sv,right)) {
1890                 cx->cx_type &= ~CXTYPEMASK;
1891                 cx->cx_type |= CXt_LOOP_LAZYIV;
1892                 /* Make sure that no-one re-orders cop.h and breaks our
1893                    assumptions */
1894                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1895 #ifdef NV_PRESERVES_UV
1896                 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1897                                   (SvNV(sv) > (NV)IV_MAX)))
1898                         ||
1899                     (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1900                                      (SvNV(right) < (NV)IV_MIN))))
1901 #else
1902                 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1903                                   ||
1904                                   ((SvNV(sv) > 0) &&
1905                                         ((SvUV(sv) > (UV)IV_MAX) ||
1906                                          (SvNV(sv) > (NV)UV_MAX)))))
1907                         ||
1908                     (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1909                                      ||
1910                                      ((SvNV(right) > 0) &&
1911                                         ((SvUV(right) > (UV)IV_MAX) ||
1912                                          (SvNV(right) > (NV)UV_MAX))))))
1913 #endif
1914                     DIE(aTHX_ "Range iterator outside integer range");
1915                 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1916                 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1917 #ifdef DEBUGGING
1918                 /* for correct -Dstv display */
1919                 cx->blk_oldsp = sp - PL_stack_base;
1920 #endif
1921             }
1922             else {
1923                 cx->cx_type &= ~CXTYPEMASK;
1924                 cx->cx_type |= CXt_LOOP_LAZYSV;
1925                 /* Make sure that no-one re-orders cop.h and breaks our
1926                    assumptions */
1927                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1928                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1929                 cx->blk_loop.state_u.lazysv.end = right;
1930                 SvREFCNT_inc(right);
1931                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1932                 /* This will do the upgrade to SVt_PV, and warn if the value
1933                    is uninitialised.  */
1934                 (void) SvPV_nolen_const(right);
1935                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1936                    to replace !SvOK() with a pointer to "".  */
1937                 if (!SvOK(right)) {
1938                     SvREFCNT_dec(right);
1939                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1940                 }
1941             }
1942         }
1943         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1944             cx->blk_loop.state_u.ary.ary = (AV*)maybe_ary;
1945             SvREFCNT_inc(maybe_ary);
1946             cx->blk_loop.state_u.ary.ix =
1947                 (PL_op->op_private & OPpITER_REVERSED) ?
1948                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1949                 -1;
1950         }
1951     }
1952     else { /* iterating over items on the stack */
1953         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1954         if (PL_op->op_private & OPpITER_REVERSED) {
1955             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1956         }
1957         else {
1958             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
1959         }
1960     }
1961
1962     RETURN;
1963 }
1964
1965 PP(pp_enterloop)
1966 {
1967     dVAR; dSP;
1968     register PERL_CONTEXT *cx;
1969     const I32 gimme = GIMME_V;
1970
1971     ENTER;
1972     SAVETMPS;
1973     ENTER;
1974
1975     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
1976     PUSHLOOP_PLAIN(cx, SP);
1977
1978     RETURN;
1979 }
1980
1981 PP(pp_leaveloop)
1982 {
1983     dVAR; dSP;
1984     register PERL_CONTEXT *cx;
1985     I32 gimme;
1986     SV **newsp;
1987     PMOP *newpm;
1988     SV **mark;
1989
1990     POPBLOCK(cx,newpm);
1991     assert(CxTYPE_is_LOOP(cx));
1992     mark = newsp;
1993     newsp = PL_stack_base + cx->blk_loop.resetsp;
1994
1995     TAINT_NOT;
1996     if (gimme == G_VOID)
1997         NOOP;
1998     else if (gimme == G_SCALAR) {
1999         if (mark < SP)
2000             *++newsp = sv_mortalcopy(*SP);
2001         else
2002             *++newsp = &PL_sv_undef;
2003     }
2004     else {
2005         while (mark < SP) {
2006             *++newsp = sv_mortalcopy(*++mark);
2007             TAINT_NOT;          /* Each item is independent */
2008         }
2009     }
2010     SP = newsp;
2011     PUTBACK;
2012
2013     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2014     PL_curpm = newpm;   /* ... and pop $1 et al */
2015
2016     LEAVE;
2017     LEAVE;
2018
2019     return NORMAL;
2020 }
2021
2022 PP(pp_return)
2023 {
2024     dVAR; dSP; dMARK;
2025     register PERL_CONTEXT *cx;
2026     bool popsub2 = FALSE;
2027     bool clear_errsv = FALSE;
2028     I32 gimme;
2029     SV **newsp;
2030     PMOP *newpm;
2031     I32 optype = 0;
2032     SV *sv;
2033     OP *retop;
2034
2035     const I32 cxix = dopoptosub(cxstack_ix);
2036
2037     if (cxix < 0) {
2038         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2039                                      * sort block, which is a CXt_NULL
2040                                      * not a CXt_SUB */
2041             dounwind(0);
2042             PL_stack_base[1] = *PL_stack_sp;
2043             PL_stack_sp = PL_stack_base + 1;
2044             return 0;
2045         }
2046         else
2047             DIE(aTHX_ "Can't return outside a subroutine");
2048     }
2049     if (cxix < cxstack_ix)
2050         dounwind(cxix);
2051
2052     if (CxMULTICALL(&cxstack[cxix])) {
2053         gimme = cxstack[cxix].blk_gimme;
2054         if (gimme == G_VOID)
2055             PL_stack_sp = PL_stack_base;
2056         else if (gimme == G_SCALAR) {
2057             PL_stack_base[1] = *PL_stack_sp;
2058             PL_stack_sp = PL_stack_base + 1;
2059         }
2060         return 0;
2061     }
2062
2063     POPBLOCK(cx,newpm);
2064     switch (CxTYPE(cx)) {
2065     case CXt_SUB:
2066         popsub2 = TRUE;
2067         retop = cx->blk_sub.retop;
2068         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2069         break;
2070     case CXt_EVAL:
2071         if (!(PL_in_eval & EVAL_KEEPERR))
2072             clear_errsv = TRUE;
2073         POPEVAL(cx);
2074         retop = cx->blk_eval.retop;
2075         if (CxTRYBLOCK(cx))
2076             break;
2077         lex_end();
2078         if (optype == OP_REQUIRE &&
2079             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2080         {
2081             /* Unassume the success we assumed earlier. */
2082             SV * const nsv = cx->blk_eval.old_namesv;
2083             (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2084             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2085         }
2086         break;
2087     case CXt_FORMAT:
2088         POPFORMAT(cx);
2089         retop = cx->blk_sub.retop;
2090         break;
2091     default:
2092         DIE(aTHX_ "panic: return");
2093     }
2094
2095     TAINT_NOT;
2096     if (gimme == G_SCALAR) {
2097         if (MARK < SP) {
2098             if (popsub2) {
2099                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2100                     if (SvTEMP(TOPs)) {
2101                         *++newsp = SvREFCNT_inc(*SP);
2102                         FREETMPS;
2103                         sv_2mortal(*newsp);
2104                     }
2105                     else {
2106                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2107                         FREETMPS;
2108                         *++newsp = sv_mortalcopy(sv);
2109                         SvREFCNT_dec(sv);
2110                     }
2111                 }
2112                 else
2113                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2114             }
2115             else
2116                 *++newsp = sv_mortalcopy(*SP);
2117         }
2118         else
2119             *++newsp = &PL_sv_undef;
2120     }
2121     else if (gimme == G_ARRAY) {
2122         while (++MARK <= SP) {
2123             *++newsp = (popsub2 && SvTEMP(*MARK))
2124                         ? *MARK : sv_mortalcopy(*MARK);
2125             TAINT_NOT;          /* Each item is independent */
2126         }
2127     }
2128     PL_stack_sp = newsp;
2129
2130     LEAVE;
2131     /* Stack values are safe: */
2132     if (popsub2) {
2133         cxstack_ix--;
2134         POPSUB(cx,sv);  /* release CV and @_ ... */
2135     }
2136     else
2137         sv = NULL;
2138     PL_curpm = newpm;   /* ... and pop $1 et al */
2139
2140     LEAVESUB(sv);
2141     if (clear_errsv)
2142         sv_setpvn(ERRSV,"",0);
2143     return retop;
2144 }
2145
2146 PP(pp_last)
2147 {
2148     dVAR; dSP;
2149     I32 cxix;
2150     register PERL_CONTEXT *cx;
2151     I32 pop2 = 0;
2152     I32 gimme;
2153     I32 optype;
2154     OP *nextop;
2155     SV **newsp;
2156     PMOP *newpm;
2157     SV **mark;
2158     SV *sv = NULL;
2159
2160
2161     if (PL_op->op_flags & OPf_SPECIAL) {
2162         cxix = dopoptoloop(cxstack_ix);
2163         if (cxix < 0)
2164             DIE(aTHX_ "Can't \"last\" outside a loop block");
2165     }
2166     else {
2167         cxix = dopoptolabel(cPVOP->op_pv);
2168         if (cxix < 0)
2169             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2170     }
2171     if (cxix < cxstack_ix)
2172         dounwind(cxix);
2173
2174     POPBLOCK(cx,newpm);
2175     cxstack_ix++; /* temporarily protect top context */
2176     mark = newsp;
2177     switch (CxTYPE(cx)) {
2178     case CXt_LOOP_LAZYIV:
2179     case CXt_LOOP_LAZYSV:
2180     case CXt_LOOP_FOR:
2181     case CXt_LOOP_PLAIN:
2182         pop2 = CxTYPE(cx);
2183         newsp = PL_stack_base + cx->blk_loop.resetsp;
2184         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2185         break;
2186     case CXt_SUB:
2187         pop2 = CXt_SUB;
2188         nextop = cx->blk_sub.retop;
2189         break;
2190     case CXt_EVAL:
2191         POPEVAL(cx);
2192         nextop = cx->blk_eval.retop;
2193         break;
2194     case CXt_FORMAT:
2195         POPFORMAT(cx);
2196         nextop = cx->blk_sub.retop;
2197         break;
2198     default:
2199         DIE(aTHX_ "panic: last");
2200     }
2201
2202     TAINT_NOT;
2203     if (gimme == G_SCALAR) {
2204         if (MARK < SP)
2205             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2206                         ? *SP : sv_mortalcopy(*SP);
2207         else
2208             *++newsp = &PL_sv_undef;
2209     }
2210     else if (gimme == G_ARRAY) {
2211         while (++MARK <= SP) {
2212             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2213                         ? *MARK : sv_mortalcopy(*MARK);
2214             TAINT_NOT;          /* Each item is independent */
2215         }
2216     }
2217     SP = newsp;
2218     PUTBACK;
2219
2220     LEAVE;
2221     cxstack_ix--;
2222     /* Stack values are safe: */
2223     switch (pop2) {
2224     case CXt_LOOP_LAZYIV:
2225     case CXt_LOOP_PLAIN:
2226     case CXt_LOOP_LAZYSV:
2227     case CXt_LOOP_FOR:
2228         POPLOOP(cx);    /* release loop vars ... */
2229         LEAVE;
2230         break;
2231     case CXt_SUB:
2232         POPSUB(cx,sv);  /* release CV and @_ ... */
2233         break;
2234     }
2235     PL_curpm = newpm;   /* ... and pop $1 et al */
2236
2237     LEAVESUB(sv);
2238     PERL_UNUSED_VAR(optype);
2239     PERL_UNUSED_VAR(gimme);
2240     return nextop;
2241 }
2242
2243 PP(pp_next)
2244 {
2245     dVAR;
2246     I32 cxix;
2247     register PERL_CONTEXT *cx;
2248     I32 inner;
2249
2250     if (PL_op->op_flags & OPf_SPECIAL) {
2251         cxix = dopoptoloop(cxstack_ix);
2252         if (cxix < 0)
2253             DIE(aTHX_ "Can't \"next\" outside a loop block");
2254     }
2255     else {
2256         cxix = dopoptolabel(cPVOP->op_pv);
2257         if (cxix < 0)
2258             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2259     }
2260     if (cxix < cxstack_ix)
2261         dounwind(cxix);
2262
2263     /* clear off anything above the scope we're re-entering, but
2264      * save the rest until after a possible continue block */
2265     inner = PL_scopestack_ix;
2266     TOPBLOCK(cx);
2267     if (PL_scopestack_ix < inner)
2268         leave_scope(PL_scopestack[PL_scopestack_ix]);
2269     PL_curcop = cx->blk_oldcop;
2270     return CX_LOOP_NEXTOP_GET(cx);
2271 }
2272
2273 PP(pp_redo)
2274 {
2275     dVAR;
2276     I32 cxix;
2277     register PERL_CONTEXT *cx;
2278     I32 oldsave;
2279     OP* redo_op;
2280
2281     if (PL_op->op_flags & OPf_SPECIAL) {
2282         cxix = dopoptoloop(cxstack_ix);
2283         if (cxix < 0)
2284             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2285     }
2286     else {
2287         cxix = dopoptolabel(cPVOP->op_pv);
2288         if (cxix < 0)
2289             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2290     }
2291     if (cxix < cxstack_ix)
2292         dounwind(cxix);
2293
2294     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2295     if (redo_op->op_type == OP_ENTER) {
2296         /* pop one less context to avoid $x being freed in while (my $x..) */
2297         cxstack_ix++;
2298         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2299         redo_op = redo_op->op_next;
2300     }
2301
2302     TOPBLOCK(cx);
2303     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2304     LEAVE_SCOPE(oldsave);
2305     FREETMPS;
2306     PL_curcop = cx->blk_oldcop;
2307     return redo_op;
2308 }
2309
2310 STATIC OP *
2311 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2312 {
2313     dVAR;
2314     OP **ops = opstack;
2315     static const char too_deep[] = "Target of goto is too deeply nested";
2316
2317     if (ops >= oplimit)
2318         Perl_croak(aTHX_ too_deep);
2319     if (o->op_type == OP_LEAVE ||
2320         o->op_type == OP_SCOPE ||
2321         o->op_type == OP_LEAVELOOP ||
2322         o->op_type == OP_LEAVESUB ||
2323         o->op_type == OP_LEAVETRY)
2324     {
2325         *ops++ = cUNOPo->op_first;
2326         if (ops >= oplimit)
2327             Perl_croak(aTHX_ too_deep);
2328     }
2329     *ops = 0;
2330     if (o->op_flags & OPf_KIDS) {
2331         OP *kid;
2332         /* First try all the kids at this level, since that's likeliest. */
2333         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2334             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2335                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2336                 return kid;
2337         }
2338         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2339             if (kid == PL_lastgotoprobe)
2340                 continue;
2341             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2342                 if (ops == opstack)
2343                     *ops++ = kid;
2344                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2345                          ops[-1]->op_type == OP_DBSTATE)
2346                     ops[-1] = kid;
2347                 else
2348                     *ops++ = kid;
2349             }
2350             if ((o = dofindlabel(kid, label, ops, oplimit)))
2351                 return o;
2352         }
2353     }
2354     *ops = 0;
2355     return 0;
2356 }
2357
2358 PP(pp_goto)
2359 {
2360     dVAR; dSP;
2361     OP *retop = NULL;
2362     I32 ix;
2363     register PERL_CONTEXT *cx;
2364 #define GOTO_DEPTH 64
2365     OP *enterops[GOTO_DEPTH];
2366     const char *label = NULL;
2367     const bool do_dump = (PL_op->op_type == OP_DUMP);
2368     static const char must_have_label[] = "goto must have label";
2369
2370     if (PL_op->op_flags & OPf_STACKED) {
2371         SV * const sv = POPs;
2372
2373         /* This egregious kludge implements goto &subroutine */
2374         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2375             I32 cxix;
2376             register PERL_CONTEXT *cx;
2377             CV* cv = (CV*)SvRV(sv);
2378             SV** mark;
2379             I32 items = 0;
2380             I32 oldsave;
2381             bool reified = 0;
2382
2383         retry:
2384             if (!CvROOT(cv) && !CvXSUB(cv)) {
2385                 const GV * const gv = CvGV(cv);
2386                 if (gv) {
2387                     GV *autogv;
2388                     SV *tmpstr;
2389                     /* autoloaded stub? */
2390                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2391                         goto retry;
2392                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2393                                           GvNAMELEN(gv), FALSE);
2394                     if (autogv && (cv = GvCV(autogv)))
2395                         goto retry;
2396                     tmpstr = sv_newmortal();
2397                     gv_efullname3(tmpstr, gv, NULL);
2398                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2399                 }
2400                 DIE(aTHX_ "Goto undefined subroutine");
2401             }
2402
2403             /* First do some returnish stuff. */
2404             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2405             FREETMPS;
2406             cxix = dopoptosub(cxstack_ix);
2407             if (cxix < 0)
2408                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2409             if (cxix < cxstack_ix)
2410                 dounwind(cxix);
2411             TOPBLOCK(cx);
2412             SPAGAIN;
2413             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2414             if (CxTYPE(cx) == CXt_EVAL) {
2415                 if (CxREALEVAL(cx))
2416                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2417                 else
2418                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2419             }
2420             else if (CxMULTICALL(cx))
2421                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2422             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2423                 /* put @_ back onto stack */
2424                 AV* av = cx->blk_sub.argarray;
2425
2426                 items = AvFILLp(av) + 1;
2427                 EXTEND(SP, items+1); /* @_ could have been extended. */
2428                 Copy(AvARRAY(av), SP + 1, items, SV*);
2429                 SvREFCNT_dec(GvAV(PL_defgv));
2430                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2431                 CLEAR_ARGARRAY(av);
2432                 /* abandon @_ if it got reified */
2433                 if (AvREAL(av)) {
2434                     reified = 1;
2435                     SvREFCNT_dec(av);
2436                     av = newAV();
2437                     av_extend(av, items-1);
2438                     AvREIFY_only(av);
2439                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2440                 }
2441             }
2442             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2443                 AV* const av = GvAV(PL_defgv);
2444                 items = AvFILLp(av) + 1;
2445                 EXTEND(SP, items+1); /* @_ could have been extended. */
2446                 Copy(AvARRAY(av), SP + 1, items, SV*);
2447             }
2448             mark = SP;
2449             SP += items;
2450             if (CxTYPE(cx) == CXt_SUB &&
2451                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2452                 SvREFCNT_dec(cx->blk_sub.cv);
2453             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2454             LEAVE_SCOPE(oldsave);
2455
2456             /* Now do some callish stuff. */
2457             SAVETMPS;
2458             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2459             if (CvISXSUB(cv)) {
2460                 OP* const retop = cx->blk_sub.retop;
2461                 SV **newsp;
2462                 I32 gimme;
2463                 if (reified) {
2464                     I32 index;
2465                     for (index=0; index<items; index++)
2466                         sv_2mortal(SP[-index]);
2467                 }
2468
2469                 /* XS subs don't have a CxSUB, so pop it */
2470                 POPBLOCK(cx, PL_curpm);
2471                 /* Push a mark for the start of arglist */
2472                 PUSHMARK(mark);
2473                 PUTBACK;
2474                 (void)(*CvXSUB(cv))(aTHX_ cv);
2475                 LEAVE;
2476                 return retop;
2477             }
2478             else {
2479                 AV* const padlist = CvPADLIST(cv);
2480                 if (CxTYPE(cx) == CXt_EVAL) {
2481                     PL_in_eval = CxOLD_IN_EVAL(cx);
2482                     PL_eval_root = cx->blk_eval.old_eval_root;
2483                     cx->cx_type = CXt_SUB;
2484                 }
2485                 cx->blk_sub.cv = cv;
2486                 cx->blk_sub.olddepth = CvDEPTH(cv);
2487
2488                 CvDEPTH(cv)++;
2489                 if (CvDEPTH(cv) < 2)
2490                     SvREFCNT_inc_simple_void_NN(cv);
2491                 else {
2492                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2493                         sub_crush_depth(cv);
2494                     pad_push(padlist, CvDEPTH(cv));
2495                 }
2496                 SAVECOMPPAD();
2497                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2498                 if (CxHASARGS(cx))
2499                 {
2500                     AV* const av = (AV*)PAD_SVl(0);
2501
2502                     cx->blk_sub.savearray = GvAV(PL_defgv);
2503                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2504                     CX_CURPAD_SAVE(cx->blk_sub);
2505                     cx->blk_sub.argarray = av;
2506
2507                     if (items >= AvMAX(av) + 1) {
2508                         SV **ary = AvALLOC(av);
2509                         if (AvARRAY(av) != ary) {
2510                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2511                             AvARRAY(av) = ary;
2512                         }
2513                         if (items >= AvMAX(av) + 1) {
2514                             AvMAX(av) = items - 1;
2515                             Renew(ary,items+1,SV*);
2516                             AvALLOC(av) = ary;
2517                             AvARRAY(av) = ary;
2518                         }
2519                     }
2520                     ++mark;
2521                     Copy(mark,AvARRAY(av),items,SV*);
2522                     AvFILLp(av) = items - 1;
2523                     assert(!AvREAL(av));
2524                     if (reified) {
2525                         /* transfer 'ownership' of refcnts to new @_ */
2526                         AvREAL_on(av);
2527                         AvREIFY_off(av);
2528                     }
2529                     while (items--) {
2530                         if (*mark)
2531                             SvTEMP_off(*mark);
2532                         mark++;
2533                     }
2534                 }
2535                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2536                     Perl_get_db_sub(aTHX_ NULL, cv);
2537                     if (PERLDB_GOTO) {
2538                         CV * const gotocv = get_cv("DB::goto", FALSE);
2539                         if (gotocv) {
2540                             PUSHMARK( PL_stack_sp );
2541                             call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2542                             PL_stack_sp--;
2543                         }
2544                     }
2545                 }
2546                 RETURNOP(CvSTART(cv));
2547             }
2548         }
2549         else {
2550             label = SvPV_nolen_const(sv);
2551             if (!(do_dump || *label))
2552                 DIE(aTHX_ must_have_label);
2553         }
2554     }
2555     else if (PL_op->op_flags & OPf_SPECIAL) {
2556         if (! do_dump)
2557             DIE(aTHX_ must_have_label);
2558     }
2559     else
2560         label = cPVOP->op_pv;
2561
2562     if (label && *label) {
2563         OP *gotoprobe = NULL;
2564         bool leaving_eval = FALSE;
2565         bool in_block = FALSE;
2566         PERL_CONTEXT *last_eval_cx = NULL;
2567
2568         /* find label */
2569
2570         PL_lastgotoprobe = NULL;
2571         *enterops = 0;
2572         for (ix = cxstack_ix; ix >= 0; ix--) {
2573             cx = &cxstack[ix];
2574             switch (CxTYPE(cx)) {
2575             case CXt_EVAL:
2576                 leaving_eval = TRUE;
2577                 if (!CxTRYBLOCK(cx)) {
2578                     gotoprobe = (last_eval_cx ?
2579                                 last_eval_cx->blk_eval.old_eval_root :
2580                                 PL_eval_root);
2581                     last_eval_cx = cx;
2582                     break;
2583                 }
2584                 /* else fall through */
2585             case CXt_LOOP_LAZYIV:
2586             case CXt_LOOP_LAZYSV:
2587             case CXt_LOOP_FOR:
2588             case CXt_LOOP_PLAIN:
2589                 gotoprobe = cx->blk_oldcop->op_sibling;
2590                 break;
2591             case CXt_SUBST:
2592                 continue;
2593             case CXt_BLOCK:
2594                 if (ix) {
2595                     gotoprobe = cx->blk_oldcop->op_sibling;
2596                     in_block = TRUE;
2597                 } else
2598                     gotoprobe = PL_main_root;
2599                 break;
2600             case CXt_SUB:
2601                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2602                     gotoprobe = CvROOT(cx->blk_sub.cv);
2603                     break;
2604                 }
2605                 /* FALL THROUGH */
2606             case CXt_FORMAT:
2607             case CXt_NULL:
2608                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2609             default:
2610                 if (ix)
2611                     DIE(aTHX_ "panic: goto");
2612                 gotoprobe = PL_main_root;
2613                 break;
2614             }
2615             if (gotoprobe) {
2616                 retop = dofindlabel(gotoprobe, label,
2617                                     enterops, enterops + GOTO_DEPTH);
2618                 if (retop)
2619                     break;
2620             }
2621             PL_lastgotoprobe = gotoprobe;
2622         }
2623         if (!retop)
2624             DIE(aTHX_ "Can't find label %s", label);
2625
2626         /* if we're leaving an eval, check before we pop any frames
2627            that we're not going to punt, otherwise the error
2628            won't be caught */
2629
2630         if (leaving_eval && *enterops && enterops[1]) {
2631             I32 i;
2632             for (i = 1; enterops[i]; i++)
2633                 if (enterops[i]->op_type == OP_ENTERITER)
2634                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2635         }
2636
2637         /* pop unwanted frames */
2638
2639         if (ix < cxstack_ix) {
2640             I32 oldsave;
2641
2642             if (ix < 0)
2643                 ix = 0;
2644             dounwind(ix);
2645             TOPBLOCK(cx);
2646             oldsave = PL_scopestack[PL_scopestack_ix];
2647             LEAVE_SCOPE(oldsave);
2648         }
2649
2650         /* push wanted frames */
2651
2652         if (*enterops && enterops[1]) {
2653             OP * const oldop = PL_op;
2654             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2655             for (; enterops[ix]; ix++) {
2656                 PL_op = enterops[ix];
2657                 /* Eventually we may want to stack the needed arguments
2658                  * for each op.  For now, we punt on the hard ones. */
2659                 if (PL_op->op_type == OP_ENTERITER)
2660                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2661                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2662             }
2663             PL_op = oldop;
2664         }
2665     }
2666
2667     if (do_dump) {
2668 #ifdef VMS
2669         if (!retop) retop = PL_main_start;
2670 #endif
2671         PL_restartop = retop;
2672         PL_do_undump = TRUE;
2673
2674         my_unexec();
2675
2676         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2677         PL_do_undump = FALSE;
2678     }
2679
2680     RETURNOP(retop);
2681 }
2682
2683 PP(pp_exit)
2684 {
2685     dVAR;
2686     dSP;
2687     I32 anum;
2688
2689     if (MAXARG < 1)
2690         anum = 0;
2691     else {
2692         anum = SvIVx(POPs);
2693 #ifdef VMS
2694         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2695             anum = 0;
2696         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2697 #endif
2698     }
2699     PL_exit_flags |= PERL_EXIT_EXPECTED;
2700 #ifdef PERL_MAD
2701     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2702     if (anum || !(PL_minus_c && PL_madskills))
2703         my_exit(anum);
2704 #else
2705     my_exit(anum);
2706 #endif
2707     PUSHs(&PL_sv_undef);
2708     RETURN;
2709 }
2710
2711 /* Eval. */
2712
2713 STATIC void
2714 S_save_lines(pTHX_ AV *array, SV *sv)
2715 {
2716     const char *s = SvPVX_const(sv);
2717     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2718     I32 line = 1;
2719
2720     while (s && s < send) {
2721         const char *t;
2722         SV * const tmpstr = newSV_type(SVt_PVMG);
2723
2724         t = strchr(s, '\n');
2725         if (t)
2726             t++;
2727         else
2728             t = send;
2729
2730         sv_setpvn(tmpstr, s, t - s);
2731         av_store(array, line++, tmpstr);
2732         s = t;
2733     }
2734 }
2735
2736 STATIC OP *
2737 S_docatch(pTHX_ OP *o)
2738 {
2739     dVAR;
2740     int ret;
2741     OP * const oldop = PL_op;
2742     dJMPENV;
2743
2744 #ifdef DEBUGGING
2745     assert(CATCH_GET == TRUE);
2746 #endif
2747     PL_op = o;
2748
2749     JMPENV_PUSH(ret);
2750     switch (ret) {
2751     case 0:
2752         assert(cxstack_ix >= 0);
2753         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2754         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2755  redo_body:
2756         CALLRUNOPS(aTHX);
2757         break;
2758     case 3:
2759         /* die caught by an inner eval - continue inner loop */
2760
2761         /* NB XXX we rely on the old popped CxEVAL still being at the top
2762          * of the stack; the way die_where() currently works, this
2763          * assumption is valid. In theory The cur_top_env value should be
2764          * returned in another global, the way retop (aka PL_restartop)
2765          * is. */
2766         assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2767
2768         if (PL_restartop
2769             && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2770         {
2771             PL_op = PL_restartop;
2772             PL_restartop = 0;
2773             goto redo_body;
2774         }
2775         /* FALL THROUGH */
2776     default:
2777         JMPENV_POP;
2778         PL_op = oldop;
2779         JMPENV_JUMP(ret);
2780         /* NOTREACHED */
2781     }
2782     JMPENV_POP;
2783     PL_op = oldop;
2784     return NULL;
2785 }
2786
2787 OP *
2788 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2789 /* sv Text to convert to OP tree. */
2790 /* startop op_free() this to undo. */
2791 /* code Short string id of the caller. */
2792 {
2793     /* FIXME - how much of this code is common with pp_entereval?  */
2794     dVAR; dSP;                          /* Make POPBLOCK work. */
2795     PERL_CONTEXT *cx;
2796     SV **newsp;
2797     I32 gimme = G_VOID;
2798     I32 optype;
2799     OP dummy;
2800     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2801     char *tmpbuf = tbuf;
2802     char *safestr;
2803     int runtime;
2804     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
2805     STRLEN len;
2806
2807     ENTER;
2808     lex_start(sv, NULL, FALSE);
2809     SAVETMPS;
2810     /* switch to eval mode */
2811
2812     if (IN_PERL_COMPILETIME) {
2813         SAVECOPSTASH_FREE(&PL_compiling);
2814         CopSTASH_set(&PL_compiling, PL_curstash);
2815     }
2816     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2817         SV * const sv = sv_newmortal();
2818         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2819                        code, (unsigned long)++PL_evalseq,
2820                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2821         tmpbuf = SvPVX(sv);
2822         len = SvCUR(sv);
2823     }
2824     else
2825         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2826                           (unsigned long)++PL_evalseq);
2827     SAVECOPFILE_FREE(&PL_compiling);
2828     CopFILE_set(&PL_compiling, tmpbuf+2);
2829     SAVECOPLINE(&PL_compiling);
2830     CopLINE_set(&PL_compiling, 1);
2831     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2832        deleting the eval's FILEGV from the stash before gv_check() runs
2833        (i.e. before run-time proper). To work around the coredump that
2834        ensues, we always turn GvMULTI_on for any globals that were
2835        introduced within evals. See force_ident(). GSAR 96-10-12 */
2836     safestr = savepvn(tmpbuf, len);
2837     SAVEDELETE(PL_defstash, safestr, len);
2838     SAVEHINTS();
2839 #ifdef OP_IN_REGISTER
2840     PL_opsave = op;
2841 #else
2842     SAVEVPTR(PL_op);
2843 #endif
2844
2845     /* we get here either during compilation, or via pp_regcomp at runtime */
2846     runtime = IN_PERL_RUNTIME;
2847     if (runtime)
2848         runcv = find_runcv(NULL);
2849
2850     PL_op = &dummy;
2851     PL_op->op_type = OP_ENTEREVAL;
2852     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2853     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2854     PUSHEVAL(cx, 0, NULL);
2855
2856     if (runtime)
2857         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2858     else
2859         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2860     POPBLOCK(cx,PL_curpm);
2861     POPEVAL(cx);
2862
2863     (*startop)->op_type = OP_NULL;
2864     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2865     lex_end();
2866     /* XXX DAPM do this properly one year */
2867     *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2868     LEAVE;
2869     if (IN_PERL_COMPILETIME)
2870         CopHINTS_set(&PL_compiling, PL_hints);
2871 #ifdef OP_IN_REGISTER
2872     op = PL_opsave;
2873 #endif
2874     PERL_UNUSED_VAR(newsp);
2875     PERL_UNUSED_VAR(optype);
2876
2877     return PL_eval_start;
2878 }
2879
2880
2881 /*
2882 =for apidoc find_runcv
2883
2884 Locate the CV corresponding to the currently executing sub or eval.
2885 If db_seqp is non_null, skip CVs that are in the DB package and populate
2886 *db_seqp with the cop sequence number at the point that the DB:: code was
2887 entered. (allows debuggers to eval in the scope of the breakpoint rather
2888 than in the scope of the debugger itself).
2889
2890 =cut
2891 */
2892
2893 CV*
2894 Perl_find_runcv(pTHX_ U32 *db_seqp)
2895 {
2896     dVAR;
2897     PERL_SI      *si;
2898
2899     if (db_seqp)
2900         *db_seqp = PL_curcop->cop_seq;
2901     for (si = PL_curstackinfo; si; si = si->si_prev) {
2902         I32 ix;
2903         for (ix = si->si_cxix; ix >= 0; ix--) {
2904             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2905             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2906                 CV * const cv = cx->blk_sub.cv;
2907                 /* skip DB:: code */
2908                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2909                     *db_seqp = cx->blk_oldcop->cop_seq;
2910                     continue;
2911                 }
2912                 return cv;
2913             }
2914             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2915                 return PL_compcv;
2916         }
2917     }
2918     return PL_main_cv;
2919 }
2920
2921
2922 /* Compile a require/do, an eval '', or a /(?{...})/.
2923  * In the last case, startop is non-null, and contains the address of
2924  * a pointer that should be set to the just-compiled code.
2925  * outside is the lexically enclosing CV (if any) that invoked us.
2926  * Returns a bool indicating whether the compile was successful; if so,
2927  * PL_eval_start contains the first op of the compiled ocde; otherwise,
2928  * pushes undef (also croaks if startop != NULL).
2929  */
2930
2931 STATIC bool
2932 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2933 {
2934     dVAR; dSP;
2935     OP * const saveop = PL_op;
2936
2937     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2938                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2939                   : EVAL_INEVAL);
2940
2941     PUSHMARK(SP);
2942
2943     SAVESPTR(PL_compcv);
2944     PL_compcv = (CV*)newSV_type(SVt_PVCV);
2945     CvEVAL_on(PL_compcv);
2946     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2947     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2948
2949     CvOUTSIDE_SEQ(PL_compcv) = seq;
2950     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2951
2952     /* set up a scratch pad */
2953
2954     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2955     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2956
2957
2958     if (!PL_madskills)
2959         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
2960
2961     /* make sure we compile in the right package */
2962
2963     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2964         SAVESPTR(PL_curstash);
2965         PL_curstash = CopSTASH(PL_curcop);
2966     }
2967     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2968     SAVESPTR(PL_beginav);
2969     PL_beginav = newAV();
2970     SAVEFREESV(PL_beginav);
2971     SAVESPTR(PL_unitcheckav);
2972     PL_unitcheckav = newAV();
2973     SAVEFREESV(PL_unitcheckav);
2974
2975 #ifdef PERL_MAD
2976     SAVEBOOL(PL_madskills);
2977     PL_madskills = 0;
2978 #endif
2979
2980     /* try to compile it */
2981
2982     PL_eval_root = NULL;
2983     PL_curcop = &PL_compiling;
2984     CopARYBASE_set(PL_curcop, 0);
2985     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2986         PL_in_eval |= EVAL_KEEPERR;
2987     else
2988         sv_setpvn(ERRSV,"",0);
2989     if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2990         SV **newsp;                     /* Used by POPBLOCK. */
2991         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2992         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2993         const char *msg;
2994
2995         PL_op = saveop;
2996         if (PL_eval_root) {
2997             op_free(PL_eval_root);
2998             PL_eval_root = NULL;
2999         }
3000         SP = PL_stack_base + POPMARK;           /* pop original mark */
3001         if (!startop) {
3002             POPBLOCK(cx,PL_curpm);
3003             POPEVAL(cx);
3004         }
3005         lex_end();
3006         LEAVE;
3007
3008         msg = SvPVx_nolen_const(ERRSV);
3009         if (optype == OP_REQUIRE) {
3010             const SV * const nsv = cx->blk_eval.old_namesv;
3011             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3012                           &PL_sv_undef, 0);
3013             Perl_croak(aTHX_ "%sCompilation failed in require",
3014                        *msg ? msg : "Unknown error\n");
3015         }
3016         else if (startop) {
3017             POPBLOCK(cx,PL_curpm);
3018             POPEVAL(cx);
3019             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3020                        (*msg ? msg : "Unknown error\n"));
3021         }
3022         else {
3023             if (!*msg) {
3024                 sv_setpvs(ERRSV, "Compilation error");
3025             }
3026         }
3027         PERL_UNUSED_VAR(newsp);
3028         PUSHs(&PL_sv_undef);
3029         PUTBACK;
3030         return FALSE;
3031     }
3032     CopLINE_set(&PL_compiling, 0);
3033     if (startop) {
3034         *startop = PL_eval_root;
3035     } else
3036         SAVEFREEOP(PL_eval_root);
3037
3038     /* Set the context for this new optree.
3039      * If the last op is an OP_REQUIRE, force scalar context.
3040      * Otherwise, propagate the context from the eval(). */
3041     if (PL_eval_root->op_type == OP_LEAVEEVAL
3042             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3043             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3044             == OP_REQUIRE)
3045         scalar(PL_eval_root);
3046     else if ((gimme & G_WANT) == G_VOID)
3047         scalarvoid(PL_eval_root);
3048     else if ((gimme & G_WANT) == G_ARRAY)
3049         list(PL_eval_root);
3050     else
3051         scalar(PL_eval_root);
3052
3053     DEBUG_x(dump_eval());
3054
3055     /* Register with debugger: */
3056     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3057         CV * const cv = get_cv("DB::postponed", FALSE);
3058         if (cv) {
3059             dSP;
3060             PUSHMARK(SP);
3061             XPUSHs((SV*)CopFILEGV(&PL_compiling));
3062             PUTBACK;
3063             call_sv((SV*)cv, G_DISCARD);
3064         }
3065     }
3066
3067     if (PL_unitcheckav)
3068         call_list(PL_scopestack_ix, PL_unitcheckav);
3069
3070     /* compiled okay, so do it */
3071
3072     CvDEPTH(PL_compcv) = 1;
3073     SP = PL_stack_base + POPMARK;               /* pop original mark */
3074     PL_op = saveop;                     /* The caller may need it. */
3075     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3076
3077     PUTBACK;
3078     return TRUE;
3079 }
3080
3081 STATIC PerlIO *
3082 S_check_type_and_open(pTHX_ const char *name)
3083 {
3084     Stat_t st;
3085     const int st_rc = PerlLIO_stat(name, &st);
3086
3087     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3088         return NULL;
3089     }
3090
3091     return PerlIO_open(name, PERL_SCRIPT_MODE);
3092 }
3093
3094 #ifndef PERL_DISABLE_PMC
3095 STATIC PerlIO *
3096 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3097 {
3098     PerlIO *fp;
3099
3100     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3101         SV *const pmcsv = newSV(namelen + 2);
3102         char *const pmc = SvPVX(pmcsv);
3103         Stat_t pmcstat;
3104
3105         memcpy(pmc, name, namelen);
3106         pmc[namelen] = 'c';
3107         pmc[namelen + 1] = '\0';
3108
3109         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3110             fp = check_type_and_open(name);
3111         }
3112         else {
3113             fp = check_type_and_open(pmc);
3114         }
3115         SvREFCNT_dec(pmcsv);
3116     }
3117     else {
3118         fp = check_type_and_open(name);
3119     }
3120     return fp;
3121 }
3122 #else
3123 #  define doopen_pm(name, namelen) check_type_and_open(name)
3124 #endif /* !PERL_DISABLE_PMC */
3125
3126 PP(pp_require)
3127 {
3128     dVAR; dSP;
3129     register PERL_CONTEXT *cx;
3130     SV *sv;
3131     const char *name;
3132     STRLEN len;
3133     char * unixname;
3134     STRLEN unixlen;
3135 #ifdef VMS
3136     int vms_unixname = 0;
3137 #endif
3138     const char *tryname = NULL;
3139     SV *namesv = NULL;
3140     const I32 gimme = GIMME_V;
3141     int filter_has_file = 0;
3142     PerlIO *tryrsfp = NULL;
3143     SV *filter_cache = NULL;
3144     SV *filter_state = NULL;
3145     SV *filter_sub = NULL;
3146     SV *hook_sv = NULL;
3147     SV *encoding;
3148     OP *op;
3149
3150     sv = POPs;
3151     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3152         sv = new_version(sv);
3153         if (!sv_derived_from(PL_patchlevel, "version"))
3154             upg_version(PL_patchlevel, TRUE);
3155         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3156             if ( vcmp(sv,PL_patchlevel) <= 0 )
3157                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3158                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3159         }
3160         else {
3161             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3162                 I32 first = 0;
3163                 AV *lav;
3164                 SV * const req = SvRV(sv);
3165                 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3166
3167                 /* get the left hand term */
3168                 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3169
3170                 first  = SvIV(*av_fetch(lav,0,0));
3171                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3172                     || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3173                     || av_len(lav) > 1               /* FP with > 3 digits */
3174                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3175                    ) {
3176                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3177                         "%"SVf", stopped", SVfARG(vnormal(req)),
3178                         SVfARG(vnormal(PL_patchlevel)));
3179                 }
3180                 else { /* probably 'use 5.10' or 'use 5.8' */
3181                     SV * hintsv = newSV(0);
3182                     I32 second = 0;
3183
3184                     if (av_len(lav)>=1)
3185                         second = SvIV(*av_fetch(lav,1,0));
3186
3187                     second /= second >= 600  ? 100 : 10;
3188                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3189                         (int)first, (int)second,0);
3190                     upg_version(hintsv, TRUE);
3191
3192                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3193                         "--this is only %"SVf", stopped",
3194                         SVfARG(vnormal(req)),
3195                         SVfARG(vnormal(hintsv)),
3196                         SVfARG(vnormal(PL_patchlevel)));
3197                 }
3198             }
3199         }
3200
3201         /* We do this only with use, not require. */
3202         if (PL_compcv &&
3203           /* If we request a version >= 5.9.5, load feature.pm with the
3204            * feature bundle that corresponds to the required version. */
3205                 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3206             SV *const importsv = vnormal(sv);
3207             *SvPVX_mutable(importsv) = ':';
3208             ENTER;
3209             Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3210             LEAVE;
3211         }
3212
3213         RETPUSHYES;
3214     }
3215     name = SvPV_const(sv, len);
3216     if (!(name && len > 0 && *name))
3217         DIE(aTHX_ "Null filename used");
3218     TAINT_PROPER("require");
3219
3220
3221 #ifdef VMS
3222     /* The key in the %ENV hash is in the syntax of file passed as the argument
3223      * usually this is in UNIX format, but sometimes in VMS format, which
3224      * can result in a module being pulled in more than once.
3225      * To prevent this, the key must be stored in UNIX format if the VMS
3226      * name can be translated to UNIX.
3227      */
3228     if ((unixname = tounixspec(name, NULL)) != NULL) {
3229         unixlen = strlen(unixname);
3230         vms_unixname = 1;
3231     }
3232     else
3233 #endif
3234     {
3235         /* if not VMS or VMS name can not be translated to UNIX, pass it
3236          * through.
3237          */
3238         unixname = (char *) name;
3239         unixlen = len;
3240     }
3241     if (PL_op->op_type == OP_REQUIRE) {
3242         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3243                                           unixname, unixlen, 0);
3244         if ( svp ) {
3245             if (*svp != &PL_sv_undef)
3246                 RETPUSHYES;
3247             else
3248                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3249                             "Compilation failed in require", unixname);
3250         }
3251     }
3252
3253     /* prepare to compile file */
3254
3255     if (path_is_absolute(name)) {
3256         tryname = name;
3257         tryrsfp = doopen_pm(name, len);
3258     }
3259 #ifdef MACOS_TRADITIONAL
3260     if (!tryrsfp) {
3261         char newname[256];
3262
3263         MacPerl_CanonDir(name, newname, 1);
3264         if (path_is_absolute(newname)) {
3265             tryname = newname;
3266             tryrsfp = doopen_pm(newname, strlen(newname));
3267         }
3268     }
3269 #endif
3270     if (!tryrsfp) {
3271         AV * const ar = GvAVn(PL_incgv);
3272         I32 i;
3273 #ifdef VMS
3274         if (vms_unixname)
3275 #endif
3276         {
3277             namesv = newSV_type(SVt_PV);
3278             for (i = 0; i <= AvFILL(ar); i++) {
3279                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3280
3281                 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3282                     mg_get(dirsv);
3283                 if (SvROK(dirsv)) {
3284                     int count;
3285                     SV **svp;
3286                     SV *loader = dirsv;
3287
3288                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3289                         && !sv_isobject(loader))
3290                     {
3291                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3292                     }
3293
3294                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3295                                    PTR2UV(SvRV(dirsv)), name);
3296                     tryname = SvPVX_const(namesv);
3297                     tryrsfp = NULL;
3298
3299                     ENTER;
3300                     SAVETMPS;
3301                     EXTEND(SP, 2);
3302
3303                     PUSHMARK(SP);
3304                     PUSHs(dirsv);
3305                     PUSHs(sv);
3306                     PUTBACK;
3307                     if (sv_isobject(loader))
3308                         count = call_method("INC", G_ARRAY);
3309                     else
3310                         count = call_sv(loader, G_ARRAY);
3311                     SPAGAIN;
3312
3313                     /* Adjust file name if the hook has set an %INC entry */
3314                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3315                     if (svp)
3316                         tryname = SvPVX_const(*svp);
3317
3318                     if (count > 0) {
3319                         int i = 0;
3320                         SV *arg;
3321
3322                         SP -= count - 1;
3323                         arg = SP[i++];
3324
3325                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3326                             && !isGV_with_GP(SvRV(arg))) {
3327                             filter_cache = SvRV(arg);
3328                             SvREFCNT_inc_simple_void_NN(filter_cache);
3329
3330                             if (i < count) {
3331                                 arg = SP[i++];
3332                             }
3333                         }
3334
3335                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3336                             arg = SvRV(arg);
3337                         }
3338
3339                         if (SvTYPE(arg) == SVt_PVGV) {
3340                             IO * const io = GvIO((GV *)arg);
3341
3342                             ++filter_has_file;
3343
3344                             if (io) {
3345                                 tryrsfp = IoIFP(io);
3346                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3347                                     PerlIO_close(IoOFP(io));
3348                                 }
3349                                 IoIFP(io) = NULL;
3350                                 IoOFP(io) = NULL;
3351                             }
3352
3353                             if (i < count) {
3354                                 arg = SP[i++];
3355                             }
3356                         }
3357
3358                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3359                             filter_sub = arg;
3360                             SvREFCNT_inc_simple_void_NN(filter_sub);
3361
3362                             if (i < count) {
3363                                 filter_state = SP[i];
3364                                 SvREFCNT_inc_simple_void(filter_state);
3365                             }
3366                         }
3367
3368                         if (!tryrsfp && (filter_cache || filter_sub)) {
3369                             tryrsfp = PerlIO_open(BIT_BUCKET,
3370                                                   PERL_SCRIPT_MODE);
3371                         }
3372                         SP--;
3373                     }
3374
3375                     PUTBACK;
3376                     FREETMPS;
3377                     LEAVE;
3378
3379                     if (tryrsfp) {
3380                         hook_sv = dirsv;
3381                         break;
3382                     }
3383
3384                     filter_has_file = 0;
3385                     if (filter_cache) {
3386                         SvREFCNT_dec(filter_cache);
3387                         filter_cache = NULL;
3388                     }
3389                     if (filter_state) {
3390                         SvREFCNT_dec(filter_state);
3391                         filter_state = NULL;
3392                     }
3393                     if (filter_sub) {
3394                         SvREFCNT_dec(filter_sub);
3395                         filter_sub = NULL;
3396                     }
3397                 }
3398                 else {
3399                   if (!path_is_absolute(name)
3400 #ifdef MACOS_TRADITIONAL
3401                         /* We consider paths of the form :a:b ambiguous and interpret them first
3402                            as global then as local
3403                         */
3404                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3405 #endif
3406                   ) {
3407                     const char *dir;
3408                     STRLEN dirlen;
3409
3410                     if (SvOK(dirsv)) {
3411                         dir = SvPV_const(dirsv, dirlen);
3412                     } else {
3413                         dir = "";
3414                         dirlen = 0;
3415                     }
3416
3417 #ifdef MACOS_TRADITIONAL
3418                     char buf1[256];
3419                     char buf2[256];
3420
3421                     MacPerl_CanonDir(name, buf2, 1);
3422                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3423 #else
3424 #  ifdef VMS
3425                     char *unixdir;
3426                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3427                         continue;
3428                     sv_setpv(namesv, unixdir);
3429                     sv_catpv(namesv, unixname);
3430 #  else
3431 #    ifdef __SYMBIAN32__
3432                     if (PL_origfilename[0] &&
3433                         PL_origfilename[1] == ':' &&
3434                         !(dir[0] && dir[1] == ':'))
3435                         Perl_sv_setpvf(aTHX_ namesv,
3436                                        "%c:%s\\%s",
3437                                        PL_origfilename[0],
3438                                        dir, name);
3439                     else
3440                         Perl_sv_setpvf(aTHX_ namesv,
3441                                        "%s\\%s",
3442                                        dir, name);
3443 #    else
3444                     /* The equivalent of
3445                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3446                        but without the need to parse the format string, or
3447                        call strlen on either pointer, and with the correct
3448                        allocation up front.  */
3449                     {
3450                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3451
3452                         memcpy(tmp, dir, dirlen);
3453                         tmp +=dirlen;
3454                         *tmp++ = '/';
3455                         /* name came from an SV, so it will have a '\0' at the
3456                            end that we can copy as part of this memcpy().  */
3457                         memcpy(tmp, name, len + 1);
3458
3459                         SvCUR_set(namesv, dirlen + len + 1);
3460
3461                         /* Don't even actually have to turn SvPOK_on() as we
3462                            access it directly with SvPVX() below.  */
3463                     }
3464 #    endif
3465 #  endif
3466 #endif
3467                     TAINT_PROPER("require");
3468                     tryname = SvPVX_const(namesv);
3469                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3470                     if (tryrsfp) {
3471                         if (tryname[0] == '.' && tryname[1] == '/')
3472                             tryname += 2;
3473                         break;
3474                     }
3475                     else if (errno == EMFILE)
3476                         /* no point in trying other paths if out of handles */
3477                         break;
3478                   }
3479                 }
3480             }
3481         }
3482     }
3483     SAVECOPFILE_FREE(&PL_compiling);
3484     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3485     SvREFCNT_dec(namesv);
3486     if (!tryrsfp) {
3487         if (PL_op->op_type == OP_REQUIRE) {
3488             const char *msgstr = name;
3489             if(errno == EMFILE) {
3490                 SV * const msg
3491                     = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
3492                                                Strerror(errno)));
3493                 msgstr = SvPV_nolen_const(msg);
3494             } else {
3495                 if (namesv) {                   /* did we lookup @INC? */
3496                     AV * const ar = GvAVn(PL_incgv);
3497                     I32 i;
3498                     SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3499                         "%s in @INC%s%s (@INC contains:",
3500                         msgstr,
3501                         (instr(msgstr, ".h ")
3502                          ? " (change .h to .ph maybe?)" : ""),
3503                         (instr(msgstr, ".ph ")
3504                          ? " (did you run h2ph?)" : "")
3505                                                               ));
3506
3507                     for (i = 0; i <= AvFILL(ar); i++) {
3508                         sv_catpvs(msg, " ");
3509                         sv_catsv(msg, *av_fetch(ar, i, TRUE));
3510                     }
3511                     sv_catpvs(msg, ")");
3512                     msgstr = SvPV_nolen_const(msg);
3513                 }
3514             }
3515             DIE(aTHX_ "Can't locate %s", msgstr);
3516         }
3517
3518         RETPUSHUNDEF;
3519     }
3520     else
3521         SETERRNO(0, SS_NORMAL);
3522
3523     /* Assume success here to prevent recursive requirement. */
3524     /* name is never assigned to again, so len is still strlen(name)  */
3525     /* Check whether a hook in @INC has already filled %INC */
3526     if (!hook_sv) {
3527         (void)hv_store(GvHVn(PL_incgv),
3528                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3529     } else {
3530         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3531         if (!svp)
3532             (void)hv_store(GvHVn(PL_incgv),
3533                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3534     }
3535
3536     ENTER;
3537     SAVETMPS;
3538     lex_start(NULL, tryrsfp, TRUE);
3539
3540     SAVEHINTS();
3541     PL_hints = 0;
3542     SAVECOMPILEWARNINGS();
3543     if (PL_dowarn & G_WARN_ALL_ON)
3544         PL_compiling.cop_warnings = pWARN_ALL ;
3545     else if (PL_dowarn & G_WARN_ALL_OFF)
3546         PL_compiling.cop_warnings = pWARN_NONE ;
3547     else
3548         PL_compiling.cop_warnings = pWARN_STD ;
3549
3550     if (filter_sub || filter_cache) {
3551         SV * const datasv = filter_add(S_run_user_filter, NULL);
3552         IoLINES(datasv) = filter_has_file;
3553         IoTOP_GV(datasv) = (GV *)filter_state;
3554         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3555         IoFMT_GV(datasv) = (GV *)filter_cache;
3556     }
3557
3558     /* switch to eval mode */
3559     PUSHBLOCK(cx, CXt_EVAL, SP);
3560     PUSHEVAL(cx, name, NULL);
3561     cx->blk_eval.retop = PL_op->op_next;
3562
3563     SAVECOPLINE(&PL_compiling);
3564     CopLINE_set(&PL_compiling, 0);
3565
3566     PUTBACK;
3567
3568     /* Store and reset encoding. */
3569     encoding = PL_encoding;
3570     PL_encoding = NULL;
3571
3572     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3573         op = DOCATCH(PL_eval_start);
3574     else
3575         op = PL_op->op_next;
3576
3577     /* Restore encoding. */
3578     PL_encoding = encoding;
3579
3580     return op;
3581 }
3582
3583 PP(pp_entereval)
3584 {
3585     dVAR; dSP;
3586     register PERL_CONTEXT *cx;
3587     SV *sv;
3588     const I32 gimme = GIMME_V;
3589     const I32 was = PL_sub_generation;
3590     char tbuf[TYPE_DIGITS(long) + 12];
3591     char *tmpbuf = tbuf;
3592     char *safestr;
3593     STRLEN len;
3594     bool ok;
3595     CV* runcv;
3596     U32 seq;
3597     HV *saved_hh = NULL;
3598     const char * const fakestr = "_<(eval )";
3599     const int fakelen = 9 + 1;
3600
3601     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3602         saved_hh = (HV*) SvREFCNT_inc(POPs);
3603     }
3604     sv = POPs;
3605
3606     TAINT_IF(SvTAINTED(sv));
3607     TAINT_PROPER("eval");
3608
3609     ENTER;
3610     lex_start(sv, NULL, FALSE);
3611     SAVETMPS;
3612
3613     /* switch to eval mode */
3614
3615     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3616         SV * const temp_sv = sv_newmortal();
3617         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3618                        (unsigned long)++PL_evalseq,
3619                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3620         tmpbuf = SvPVX(temp_sv);
3621         len = SvCUR(temp_sv);
3622     }
3623     else
3624         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3625     SAVECOPFILE_FREE(&PL_compiling);
3626     CopFILE_set(&PL_compiling, tmpbuf+2);
3627     SAVECOPLINE(&PL_compiling);
3628     CopLINE_set(&PL_compiling, 1);
3629     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3630        deleting the eval's FILEGV from the stash before gv_check() runs
3631        (i.e. before run-time proper). To work around the coredump that
3632        ensues, we always turn GvMULTI_on for any globals that were
3633        introduced within evals. See force_ident(). GSAR 96-10-12 */
3634     safestr = savepvn(tmpbuf, len);
3635     SAVEDELETE(PL_defstash, safestr, len);
3636     SAVEHINTS();
3637     PL_hints = PL_op->op_targ;
3638     if (saved_hh)
3639         GvHV(PL_hintgv) = saved_hh;
3640     SAVECOMPILEWARNINGS();
3641     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3642     if (PL_compiling.cop_hints_hash) {
3643         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3644     }
3645     PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3646     if (PL_compiling.cop_hints_hash) {
3647         HINTS_REFCNT_LOCK;
3648         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3649         HINTS_REFCNT_UNLOCK;
3650     }
3651     /* special case: an eval '' executed within the DB package gets lexically
3652      * placed in the first non-DB CV rather than the current CV - this
3653      * allows the debugger to execute code, find lexicals etc, in the
3654      * scope of the code being debugged. Passing &seq gets find_runcv
3655      * to do the dirty work for us */
3656     runcv = find_runcv(&seq);
3657
3658     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3659     PUSHEVAL(cx, 0, NULL);
3660     cx->blk_eval.retop = PL_op->op_next;
3661
3662     /* prepare to compile string */
3663
3664     if (PERLDB_LINE && PL_curstash != PL_debstash)
3665         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3666     PUTBACK;
3667     ok = doeval(gimme, NULL, runcv, seq);
3668     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3669         && ok) {
3670         /* Copy in anything fake and short. */
3671         my_strlcpy(safestr, fakestr, fakelen);
3672     }
3673     return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3674 }
3675
3676 PP(pp_leaveeval)
3677 {
3678     dVAR; dSP;
3679     register SV **mark;
3680     SV **newsp;
3681     PMOP *newpm;
3682     I32 gimme;
3683     register PERL_CONTEXT *cx;
3684     OP *retop;
3685     const U8 save_flags = PL_op -> op_flags;
3686     I32 optype;
3687
3688     POPBLOCK(cx,newpm);
3689     POPEVAL(cx);
3690     retop = cx->blk_eval.retop;
3691
3692     TAINT_NOT;
3693     if (gimme == G_VOID)
3694         MARK = newsp;
3695     else if (gimme == G_SCALAR) {
3696         MARK = newsp + 1;
3697         if (MARK <= SP) {
3698             if (SvFLAGS(TOPs) & SVs_TEMP)
3699                 *MARK = TOPs;
3700             else
3701                 *MARK = sv_mortalcopy(TOPs);
3702         }
3703         else {
3704             MEXTEND(mark,0);
3705             *MARK = &PL_sv_undef;
3706         }
3707         SP = MARK;
3708     }
3709     else {
3710         /* in case LEAVE wipes old return values */
3711         for (mark = newsp + 1; mark <= SP; mark++) {
3712             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3713                 *mark = sv_mortalcopy(*mark);
3714                 TAINT_NOT;      /* Each item is independent */
3715             }
3716         }
3717     }
3718     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3719
3720 #ifdef DEBUGGING
3721     assert(CvDEPTH(PL_compcv) == 1);
3722 #endif
3723     CvDEPTH(PL_compcv) = 0;
3724     lex_end();
3725
3726     if (optype == OP_REQUIRE &&
3727         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3728     {
3729         /* Unassume the success we assumed earlier. */
3730         SV * const nsv = cx->blk_eval.old_namesv;
3731         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3732         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3733         /* die_where() did LEAVE, or we won't be here */
3734     }
3735     else {
3736         LEAVE;
3737         if (!(save_flags & OPf_SPECIAL))
3738             sv_setpvn(ERRSV,"",0);
3739     }
3740
3741     RETURNOP(retop);
3742 }
3743
3744 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3745    close to the related Perl_create_eval_scope.  */
3746 void
3747 Perl_delete_eval_scope(pTHX)
3748 {
3749     SV **newsp;
3750     PMOP *newpm;
3751     I32 gimme;
3752     register PERL_CONTEXT *cx;
3753     I32 optype;
3754
3755     POPBLOCK(cx,newpm);
3756     POPEVAL(cx);
3757     PL_curpm = newpm;
3758     LEAVE;
3759     PERL_UNUSED_VAR(newsp);
3760     PERL_UNUSED_VAR(gimme);
3761     PERL_UNUSED_VAR(optype);
3762 }
3763
3764 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3765    also needed by Perl_fold_constants.  */
3766 PERL_CONTEXT *
3767 Perl_create_eval_scope(pTHX_ U32 flags)
3768 {
3769     PERL_CONTEXT *cx;
3770     const I32 gimme = GIMME_V;
3771
3772     ENTER;
3773     SAVETMPS;
3774
3775     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3776     PUSHEVAL(cx, 0, 0);
3777
3778     PL_in_eval = EVAL_INEVAL;
3779     if (flags & G_KEEPERR)
3780         PL_in_eval |= EVAL_KEEPERR;
3781     else
3782         sv_setpvn(ERRSV,"",0);
3783     if (flags & G_FAKINGEVAL) {
3784         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3785     }
3786     return cx;
3787 }
3788
3789 PP(pp_entertry)
3790 {
3791     dVAR;
3792     PERL_CONTEXT * const cx = create_eval_scope(0);
3793     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3794     return DOCATCH(PL_op->op_next);
3795 }
3796
3797 PP(pp_leavetry)
3798 {
3799     dVAR; dSP;
3800     SV **newsp;
3801     PMOP *newpm;
3802     I32 gimme;
3803     register PERL_CONTEXT *cx;
3804     I32 optype;
3805
3806     POPBLOCK(cx,newpm);
3807     POPEVAL(cx);
3808     PERL_UNUSED_VAR(optype);
3809
3810     TAINT_NOT;
3811     if (gimme == G_VOID)
3812         SP = newsp;
3813     else if (gimme == G_SCALAR) {
3814         register SV **mark;
3815         MARK = newsp + 1;
3816         if (MARK <= SP) {
3817             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3818                 *MARK = TOPs;
3819             else
3820                 *MARK = sv_mortalcopy(TOPs);
3821         }
3822         else {
3823             MEXTEND(mark,0);
3824             *MARK = &PL_sv_undef;
3825         }
3826         SP = MARK;
3827     }
3828     else {
3829         /* in case LEAVE wipes old return values */
3830         register SV **mark;
3831         for (mark = newsp + 1; mark <= SP; mark++) {
3832             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3833                 *mark = sv_mortalcopy(*mark);
3834                 TAINT_NOT;      /* Each item is independent */
3835             }
3836         }
3837     }
3838     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3839
3840     LEAVE;
3841     sv_setpvn(ERRSV,"",0);
3842     RETURN;
3843 }
3844
3845 PP(pp_entergiven)
3846 {
3847     dVAR; dSP;
3848     register PERL_CONTEXT *cx;
3849     const I32 gimme = GIMME_V;
3850
3851     ENTER;
3852     SAVETMPS;
3853
3854     if (PL_op->op_targ == 0) {
3855         SV ** const defsv_p = &GvSV(PL_defgv);
3856         *defsv_p = newSVsv(POPs);
3857         SAVECLEARSV(*defsv_p);
3858     }
3859     else
3860         sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3861
3862     PUSHBLOCK(cx, CXt_GIVEN, SP);
3863     PUSHGIVEN(cx);
3864
3865     RETURN;
3866 }
3867
3868 PP(pp_leavegiven)
3869 {
3870     dVAR; dSP;
3871     register PERL_CONTEXT *cx;
3872     I32 gimme;
3873     SV **newsp;
3874     PMOP *newpm;
3875     PERL_UNUSED_CONTEXT;
3876
3877     POPBLOCK(cx,newpm);
3878     assert(CxTYPE(cx) == CXt_GIVEN);
3879
3880     SP = newsp;
3881     PUTBACK;
3882
3883     PL_curpm = newpm;   /* pop $1 et al */
3884
3885     LEAVE;
3886
3887     return NORMAL;
3888 }
3889
3890 /* Helper routines used by pp_smartmatch */
3891 STATIC PMOP *
3892 S_make_matcher(pTHX_ REGEXP *re)
3893 {
3894     dVAR;
3895     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3896     PM_SETRE(matcher, ReREFCNT_inc(re));
3897
3898     SAVEFREEOP((OP *) matcher);
3899     ENTER; SAVETMPS;
3900     SAVEOP();
3901     return matcher;
3902 }
3903
3904 STATIC bool
3905 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3906 {
3907     dVAR;
3908     dSP;
3909
3910     PL_op = (OP *) matcher;
3911     XPUSHs(sv);
3912     PUTBACK;
3913     (void) pp_match();
3914     SPAGAIN;
3915     return (SvTRUEx(POPs));
3916 }
3917
3918 STATIC void
3919 S_destroy_matcher(pTHX_ PMOP *matcher)
3920 {
3921     dVAR;
3922     PERL_UNUSED_ARG(matcher);
3923     FREETMPS;
3924     LEAVE;
3925 }
3926
3927 /* Do a smart match */
3928 PP(pp_smartmatch)
3929 {
3930     return do_smartmatch(NULL, NULL);
3931 }
3932
3933 /* This version of do_smartmatch() implements the
3934  * table of smart matches that is found in perlsyn.
3935  */
3936 STATIC OP *
3937 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3938 {
3939     dVAR;
3940     dSP;
3941
3942     SV *e = TOPs;       /* e is for 'expression' */
3943     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
3944     SV *This, *Other;   /* 'This' (and Other to match) to play with C++ */
3945     REGEXP *this_regex, *other_regex;
3946
3947 #   define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3948
3949 #   define SM_REF(type) ( \
3950            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3951         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3952
3953 #   define SM_CV_NEP   /* Find a code ref without an empty prototype */ \
3954         ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV)              \
3955             && NOT_EMPTY_PROTO(This) && (Other = e))                    \
3956         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV)            \
3957             && NOT_EMPTY_PROTO(This) && (Other = d)))
3958
3959 #   define SM_REGEX ( \
3960            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP)          \
3961         && (this_regex = (REGEXP*) This)                                \
3962         && (Other = e))                                                 \
3963     ||                                                                  \
3964            (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP)          \
3965         && (this_regex = (REGEXP*) This)                                \
3966         && (Other = d)) )
3967
3968
3969 #   define SM_OTHER_REF(type) \
3970         (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3971
3972 #   define SM_OTHER_REGEX (SvROK(Other)                                 \
3973         && (SvTYPE(SvRV(Other)) == SVt_REGEXP)                          \
3974         && (other_regex = (REGEXP*) SvRV(Other)))
3975
3976
3977 #   define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3978         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3979
3980 #   define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3981         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3982
3983     tryAMAGICbinSET(smart, 0);
3984
3985     SP -= 2;    /* Pop the values */
3986
3987     /* Take care only to invoke mg_get() once for each argument.
3988      * Currently we do this by copying the SV if it's magical. */
3989     if (d) {
3990         if (SvGMAGICAL(d))
3991             d = sv_mortalcopy(d);
3992     }
3993     else
3994         d = &PL_sv_undef;
3995
3996     assert(e);
3997     if (SvGMAGICAL(e))
3998         e = sv_mortalcopy(e);
3999
4000     if (SM_CV_NEP) {
4001         I32 c;
4002
4003         if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4004         {
4005             if (This == SvRV(Other))
4006                 RETPUSHYES;
4007             else
4008                 RETPUSHNO;
4009         }
4010
4011         ENTER;
4012         SAVETMPS;
4013         PUSHMARK(SP);
4014         PUSHs(Other);
4015         PUTBACK;
4016         c = call_sv(This, G_SCALAR);
4017         SPAGAIN;
4018         if (c == 0)
4019             PUSHs(&PL_sv_no);
4020         else if (SvTEMP(TOPs))
4021             SvREFCNT_inc_void(TOPs);
4022         FREETMPS;
4023         LEAVE;
4024         RETURN;
4025     }
4026     else if (SM_REF(PVHV)) {
4027         if (SM_OTHER_REF(PVHV)) {
4028             /* Check that the key-sets are identical */
4029             HE *he;
4030             HV *other_hv = (HV *) SvRV(Other);
4031             bool tied = FALSE;
4032             bool other_tied = FALSE;
4033             U32 this_key_count  = 0,
4034                 other_key_count = 0;
4035
4036             /* Tied hashes don't know how many keys they have. */
4037             if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4038                 tied = TRUE;
4039             }
4040             else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
4041                 HV * const temp = other_hv;
4042                 other_hv = (HV *) This;
4043                 This  = (SV *) temp;
4044                 tied = TRUE;
4045             }
4046             if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4047                 other_tied = TRUE;
4048
4049             if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4050                 RETPUSHNO;
4051
4052             /* The hashes have the same number of keys, so it suffices
4053                to check that one is a subset of the other. */
4054             (void) hv_iterinit((HV *) This);
4055             while ( (he = hv_iternext((HV *) This)) ) {
4056                 I32 key_len;
4057                 char * const key = hv_iterkey(he, &key_len);
4058
4059                 ++ this_key_count;
4060
4061                 if(!hv_exists(other_hv, key, key_len)) {
4062                     (void) hv_iterinit((HV *) This);    /* reset iterator */
4063                     RETPUSHNO;
4064                 }
4065             }
4066
4067             if (other_tied) {
4068                 (void) hv_iterinit(other_hv);
4069                 while ( hv_iternext(other_hv) )
4070                     ++other_key_count;
4071             }
4072             else
4073                 other_key_count = HvUSEDKEYS(other_hv);
4074
4075             if (this_key_count != other_key_count)
4076                 RETPUSHNO;
4077             else
4078                 RETPUSHYES;
4079         }
4080         else if (SM_OTHER_REF(PVAV)) {
4081             AV * const other_av = (AV *) SvRV(Other);
4082             const I32 other_len = av_len(other_av) + 1;
4083             I32 i;
4084
4085             for (i = 0; i < other_len; ++i) {
4086                 SV ** const svp = av_fetch(other_av, i, FALSE);
4087                 char *key;
4088                 STRLEN key_len;
4089
4090                 if (svp) {      /* ??? When can this not happen? */
4091                     key = SvPV(*svp, key_len);
4092                     if (hv_exists((HV *) This, key, key_len))
4093                         RETPUSHYES;
4094                 }
4095             }
4096             RETPUSHNO;
4097         }
4098         else if (SM_OTHER_REGEX) {
4099             PMOP * const matcher = make_matcher(other_regex);
4100             HE *he;
4101
4102             (void) hv_iterinit((HV *) This);
4103             while ( (he = hv_iternext((HV *) This)) ) {
4104                 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4105                     (void) hv_iterinit((HV *) This);
4106                     destroy_matcher(matcher);
4107                     RETPUSHYES;
4108                 }
4109             }
4110             destroy_matcher(matcher);
4111             RETPUSHNO;
4112         }
4113         else {
4114             if (hv_exists_ent((HV *) This, Other, 0))
4115                 RETPUSHYES;
4116             else
4117                 RETPUSHNO;
4118         }
4119     }
4120     else if (SM_REF(PVAV)) {
4121         if (SM_OTHER_REF(PVAV)) {
4122             AV *other_av = (AV *) SvRV(Other);
4123             if (av_len((AV *) This) != av_len(other_av))
4124                 RETPUSHNO;
4125             else {
4126                 I32 i;
4127                 const I32 other_len = av_len(other_av);
4128
4129                 if (NULL == seen_this) {
4130                     seen_this = newHV();
4131                     (void) sv_2mortal((SV *) seen_this);
4132                 }
4133                 if (NULL == seen_other) {
4134                     seen_this = newHV();
4135                     (void) sv_2mortal((SV *) seen_other);
4136                 }
4137                 for(i = 0; i <= other_len; ++i) {
4138                     SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4139                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4140
4141                     if (!this_elem || !other_elem) {
4142                         if (this_elem || other_elem)
4143                             RETPUSHNO;
4144                     }
4145                     else if (SM_SEEN_THIS(*this_elem)
4146                          || SM_SEEN_OTHER(*other_elem))
4147                     {
4148                         if (*this_elem != *other_elem)
4149                             RETPUSHNO;
4150                     }
4151                     else {
4152                         (void)hv_store_ent(seen_this,
4153                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4154                                 &PL_sv_undef, 0);
4155                         (void)hv_store_ent(seen_other,
4156                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4157                                 &PL_sv_undef, 0);
4158                         PUSHs(*this_elem);
4159                         PUSHs(*other_elem);
4160
4161                         PUTBACK;
4162                         (void) do_smartmatch(seen_this, seen_other);
4163                         SPAGAIN;
4164
4165                         if (!SvTRUEx(POPs))
4166                             RETPUSHNO;
4167                     }
4168                 }
4169                 RETPUSHYES;
4170             }
4171         }
4172         else if (SM_OTHER_REGEX) {
4173             PMOP * const matcher = make_matcher(other_regex);
4174             const I32 this_len = av_len((AV *) This);
4175             I32 i;
4176
4177             for(i = 0; i <= this_len; ++i) {
4178                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4179                 if (svp && matcher_matches_sv(matcher, *svp)) {
4180                     destroy_matcher(matcher);
4181                     RETPUSHYES;
4182                 }
4183             }
4184             destroy_matcher(matcher);
4185             RETPUSHNO;
4186         }
4187         else if (SvIOK(Other) || SvNOK(Other)) {
4188             I32 i;
4189
4190             for(i = 0; i <= AvFILL((AV *) This); ++i) {
4191                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4192                 if (!svp)
4193                     continue;
4194
4195                 PUSHs(Other);
4196                 PUSHs(*svp);
4197                 PUTBACK;
4198                 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4199                     (void) pp_i_eq();
4200                 else
4201                     (void) pp_eq();
4202                 SPAGAIN;
4203                 if (SvTRUEx(POPs))
4204                     RETPUSHYES;
4205             }
4206             RETPUSHNO;
4207         }
4208         else if (SvPOK(Other)) {
4209             const I32 this_len = av_len((AV *) This);
4210             I32 i;
4211
4212             for(i = 0; i <= this_len; ++i) {
4213                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4214                 if (!svp)
4215                     continue;
4216
4217                 PUSHs(Other);
4218                 PUSHs(*svp);
4219                 PUTBACK;
4220                 (void) pp_seq();
4221                 SPAGAIN;
4222                 if (SvTRUEx(POPs))
4223                     RETPUSHYES;
4224             }
4225             RETPUSHNO;
4226         }
4227     }
4228     else if (!SvOK(d) || !SvOK(e)) {
4229         if (!SvOK(d) && !SvOK(e))
4230             RETPUSHYES;
4231         else
4232             RETPUSHNO;
4233     }
4234     else if (SM_REGEX) {
4235         PMOP * const matcher = make_matcher(this_regex);
4236
4237         PUTBACK;
4238         PUSHs(matcher_matches_sv(matcher, Other)
4239             ? &PL_sv_yes
4240             : &PL_sv_no);
4241         destroy_matcher(matcher);
4242         RETURN;
4243     }
4244     else if (SM_REF(PVCV)) {
4245         I32 c;
4246         /* This must be a null-prototyped sub, because we
4247            already checked for the other kind. */
4248
4249         ENTER;
4250         SAVETMPS;
4251         PUSHMARK(SP);
4252         PUTBACK;
4253         c = call_sv(This, G_SCALAR);
4254         SPAGAIN;
4255         if (c == 0)
4256             PUSHs(&PL_sv_undef);
4257         else if (SvTEMP(TOPs))
4258             SvREFCNT_inc_void(TOPs);
4259
4260         if (SM_OTHER_REF(PVCV)) {
4261             /* This one has to be null-proto'd too.
4262                Call both of 'em, and compare the results */
4263             PUSHMARK(SP);
4264             c = call_sv(SvRV(Other), G_SCALAR);
4265             SPAGAIN;
4266             if (c == 0)
4267                 PUSHs(&PL_sv_undef);
4268             else if (SvTEMP(TOPs))
4269                 SvREFCNT_inc_void(TOPs);
4270             FREETMPS;
4271             LEAVE;
4272             PUTBACK;
4273             return pp_eq();
4274         }
4275
4276         FREETMPS;
4277         LEAVE;
4278         RETURN;
4279     }
4280     else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4281          ||   ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4282     {
4283         if (SvPOK(Other) && !looks_like_number(Other)) {
4284             /* String comparison */
4285             PUSHs(d); PUSHs(e);
4286             PUTBACK;
4287             return pp_seq();
4288         }
4289         /* Otherwise, numeric comparison */
4290         PUSHs(d); PUSHs(e);
4291         PUTBACK;
4292         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4293             (void) pp_i_eq();
4294         else
4295             (void) pp_eq();
4296         SPAGAIN;
4297         if (SvTRUEx(POPs))
4298             RETPUSHYES;
4299         else
4300             RETPUSHNO;
4301     }
4302
4303     /* As a last resort, use string comparison */
4304     PUSHs(d); PUSHs(e);
4305     PUTBACK;
4306     return pp_seq();
4307 }
4308
4309 PP(pp_enterwhen)
4310 {
4311     dVAR; dSP;
4312     register PERL_CONTEXT *cx;
4313     const I32 gimme = GIMME_V;
4314
4315     /* This is essentially an optimization: if the match
4316        fails, we don't want to push a context and then
4317        pop it again right away, so we skip straight
4318        to the op that follows the leavewhen.
4319     */
4320     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4321         return cLOGOP->op_other->op_next;
4322
4323     ENTER;
4324     SAVETMPS;
4325
4326     PUSHBLOCK(cx, CXt_WHEN, SP);
4327     PUSHWHEN(cx);
4328
4329     RETURN;
4330 }
4331
4332 PP(pp_leavewhen)
4333 {
4334     dVAR; dSP;
4335     register PERL_CONTEXT *cx;
4336     I32 gimme;
4337     SV **newsp;
4338     PMOP *newpm;
4339
4340     POPBLOCK(cx,newpm);
4341     assert(CxTYPE(cx) == CXt_WHEN);
4342
4343     SP = newsp;
4344     PUTBACK;
4345
4346     PL_curpm = newpm;   /* pop $1 et al */
4347
4348     LEAVE;
4349     return NORMAL;
4350 }
4351
4352 PP(pp_continue)
4353 {
4354     dVAR;
4355     I32 cxix;
4356     register PERL_CONTEXT *cx;
4357     I32 inner;
4358
4359     cxix = dopoptowhen(cxstack_ix);
4360     if (cxix < 0)
4361         DIE(aTHX_ "Can't \"continue\" outside a when block");
4362     if (cxix < cxstack_ix)
4363         dounwind(cxix);
4364
4365     /* clear off anything above the scope we're re-entering */
4366     inner = PL_scopestack_ix;
4367     TOPBLOCK(cx);
4368     if (PL_scopestack_ix < inner)
4369         leave_scope(PL_scopestack[PL_scopestack_ix]);
4370     PL_curcop = cx->blk_oldcop;
4371     return cx->blk_givwhen.leave_op;
4372 }
4373
4374 PP(pp_break)
4375 {
4376     dVAR;
4377     I32 cxix;
4378     register PERL_CONTEXT *cx;
4379     I32 inner;
4380
4381     cxix = dopoptogiven(cxstack_ix);
4382     if (cxix < 0) {
4383         if (PL_op->op_flags & OPf_SPECIAL)
4384             DIE(aTHX_ "Can't use when() outside a topicalizer");
4385         else
4386             DIE(aTHX_ "Can't \"break\" outside a given block");
4387     }
4388     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4389         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4390
4391     if (cxix < cxstack_ix)
4392         dounwind(cxix);
4393
4394     /* clear off anything above the scope we're re-entering */
4395     inner = PL_scopestack_ix;
4396     TOPBLOCK(cx);
4397     if (PL_scopestack_ix < inner)
4398         leave_scope(PL_scopestack[PL_scopestack_ix]);
4399     PL_curcop = cx->blk_oldcop;
4400
4401     if (CxFOREACH(cx))
4402         return CX_LOOP_NEXTOP_GET(cx);
4403     else
4404         return cx->blk_givwhen.leave_op;
4405 }
4406
4407 STATIC OP *
4408 S_doparseform(pTHX_ SV *sv)
4409 {
4410     STRLEN len;
4411     register char *s = SvPV_force(sv, len);
4412     register char * const send = s + len;
4413     register char *base = NULL;
4414     register I32 skipspaces = 0;
4415     bool noblank   = FALSE;
4416     bool repeat    = FALSE;
4417     bool postspace = FALSE;
4418     U32 *fops;
4419     register U32 *fpc;
4420     U32 *linepc = NULL;
4421     register I32 arg;
4422     bool ischop;
4423     bool unchopnum = FALSE;
4424     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4425
4426     if (len == 0)
4427         Perl_croak(aTHX_ "Null picture in formline");
4428
4429     /* estimate the buffer size needed */
4430     for (base = s; s <= send; s++) {
4431         if (*s == '\n' || *s == '@' || *s == '^')
4432             maxops += 10;
4433     }
4434     s = base;
4435     base = NULL;
4436
4437     Newx(fops, maxops, U32);
4438     fpc = fops;
4439
4440     if (s < send) {
4441         linepc = fpc;
4442         *fpc++ = FF_LINEMARK;
4443         noblank = repeat = FALSE;
4444         base = s;
4445     }
4446
4447     while (s <= send) {
4448         switch (*s++) {
4449         default:
4450             skipspaces = 0;
4451             continue;
4452
4453         case '~':
4454             if (*s == '~') {
4455                 repeat = TRUE;
4456                 *s = ' ';
4457             }
4458             noblank = TRUE;
4459             s[-1] = ' ';
4460             /* FALL THROUGH */
4461         case ' ': case '\t':
4462             skipspaces++;
4463             continue;
4464         case 0:
4465             if (s < send) {
4466                 skipspaces = 0;
4467                 continue;
4468             } /* else FALL THROUGH */
4469         case '\n':
4470             arg = s - base;
4471             skipspaces++;
4472             arg -= skipspaces;
4473             if (arg) {
4474                 if (postspace)
4475                     *fpc++ = FF_SPACE;
4476                 *fpc++ = FF_LITERAL;
4477                 *fpc++ = (U16)arg;
4478             }
4479             postspace = FALSE;
4480             if (s <= send)
4481                 skipspaces--;
4482             if (skipspaces) {
4483                 *fpc++ = FF_SKIP;
4484                 *fpc++ = (U16)skipspaces;
4485             }
4486             skipspaces = 0;
4487             if (s <= send)
4488                 *fpc++ = FF_NEWLINE;
4489             if (noblank) {
4490                 *fpc++ = FF_BLANK;
4491                 if (repeat)
4492                     arg = fpc - linepc + 1;
4493                 else
4494                     arg = 0;
4495                 *fpc++ = (U16)arg;
4496             }
4497             if (s < send) {
4498                 linepc = fpc;
4499                 *fpc++ = FF_LINEMARK;
4500                 noblank = repeat = FALSE;
4501                 base = s;
4502             }
4503             else
4504                 s++;
4505             continue;
4506
4507         case '@':
4508         case '^':
4509             ischop = s[-1] == '^';
4510
4511             if (postspace) {
4512                 *fpc++ = FF_SPACE;
4513                 postspace = FALSE;
4514             }
4515             arg = (s - base) - 1;
4516             if (arg) {
4517                 *fpc++ = FF_LITERAL;
4518                 *fpc++ = (U16)arg;
4519             }
4520
4521             base = s - 1;
4522             *fpc++ = FF_FETCH;
4523             if (*s == '*') {
4524                 s++;
4525                 *fpc++ = 2;  /* skip the @* or ^* */
4526                 if (ischop) {
4527                     *fpc++ = FF_LINESNGL;
4528                     *fpc++ = FF_CHOP;
4529                 } else
4530                     *fpc++ = FF_LINEGLOB;
4531             }
4532             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4533                 arg = ischop ? 512 : 0;
4534                 base = s - 1;
4535                 while (*s == '#')
4536                     s++;
4537                 if (*s == '.') {
4538                     const char * const f = ++s;
4539                     while (*s == '#')
4540                         s++;
4541                     arg |= 256 + (s - f);
4542                 }
4543                 *fpc++ = s - base;              /* fieldsize for FETCH */
4544                 *fpc++ = FF_DECIMAL;
4545                 *fpc++ = (U16)arg;
4546                 unchopnum |= ! ischop;
4547             }
4548             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4549                 arg = ischop ? 512 : 0;
4550                 base = s - 1;
4551                 s++;                                /* skip the '0' first */
4552                 while (*s == '#')
4553                     s++;
4554                 if (*s == '.') {
4555                     const char * const f = ++s;
4556                     while (*s == '#')
4557                         s++;
4558                     arg |= 256 + (s - f);
4559                 }
4560                 *fpc++ = s - base;                /* fieldsize for FETCH */
4561                 *fpc++ = FF_0DECIMAL;
4562                 *fpc++ = (U16)arg;
4563                 unchopnum |= ! ischop;
4564             }
4565             else {
4566                 I32 prespace = 0;
4567                 bool ismore = FALSE;
4568
4569                 if (*s == '>') {
4570                     while (*++s == '>') ;
4571                     prespace = FF_SPACE;
4572                 }
4573                 else if (*s == '|') {
4574                     while (*++s == '|') ;
4575                     prespace = FF_HALFSPACE;
4576                     postspace = TRUE;
4577                 }
4578                 else {
4579                     if (*s == '<')
4580                         while (*++s == '<') ;
4581                     postspace = TRUE;
4582                 }
4583                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4584                     s += 3;
4585                     ismore = TRUE;
4586                 }
4587                 *fpc++ = s - base;              /* fieldsize for FETCH */
4588
4589                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4590
4591                 if (prespace)
4592                     *fpc++ = (U16)prespace;
4593                 *fpc++ = FF_ITEM;
4594                 if (ismore)
4595                     *fpc++ = FF_MORE;
4596                 if (ischop)
4597                     *fpc++ = FF_CHOP;
4598             }
4599             base = s;
4600             skipspaces = 0;
4601             continue;
4602         }
4603     }
4604     *fpc++ = FF_END;
4605
4606     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4607     arg = fpc - fops;
4608     { /* need to jump to the next word */
4609         int z;
4610         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4611         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4612         s = SvPVX(sv) + SvCUR(sv) + z;
4613     }
4614     Copy(fops, s, arg, U32);
4615     Safefree(fops);
4616     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4617     SvCOMPILED_on(sv);
4618
4619     if (unchopnum && repeat)
4620         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4621     return 0;
4622 }
4623
4624
4625 STATIC bool
4626 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4627 {
4628     /* Can value be printed in fldsize chars, using %*.*f ? */
4629     NV pwr = 1;
4630     NV eps = 0.5;
4631     bool res = FALSE;
4632     int intsize = fldsize - (value < 0 ? 1 : 0);
4633
4634     if (frcsize & 256)
4635         intsize--;
4636     frcsize &= 255;
4637     intsize -= frcsize;
4638
4639     while (intsize--) pwr *= 10.0;
4640     while (frcsize--) eps /= 10.0;
4641
4642     if( value >= 0 ){
4643         if (value + eps >= pwr)
4644             res = TRUE;
4645     } else {
4646         if (value - eps <= -pwr)
4647             res = TRUE;
4648     }
4649     return res;
4650 }
4651
4652 static I32
4653 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4654 {
4655     dVAR;
4656     SV * const datasv = FILTER_DATA(idx);
4657     const int filter_has_file = IoLINES(datasv);
4658     SV * const filter_state = (SV *)IoTOP_GV(datasv);
4659     SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4660     int status = 0;
4661     SV *upstream;
4662     STRLEN got_len;
4663     const char *got_p = NULL;
4664     const char *prune_from = NULL;
4665     bool read_from_cache = FALSE;
4666     STRLEN umaxlen;
4667
4668     assert(maxlen >= 0);
4669     umaxlen = maxlen;
4670
4671     /* I was having segfault trouble under Linux 2.2.5 after a
4672        parse error occured.  (Had to hack around it with a test
4673        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4674        not sure where the trouble is yet.  XXX */
4675
4676     if (IoFMT_GV(datasv)) {
4677         SV *const cache = (SV *)IoFMT_GV(datasv);
4678         if (SvOK(cache)) {
4679             STRLEN cache_len;
4680             const char *cache_p = SvPV(cache, cache_len);
4681             STRLEN take = 0;
4682
4683             if (umaxlen) {
4684                 /* Running in block mode and we have some cached data already.
4685                  */
4686                 if (cache_len >= umaxlen) {
4687                     /* In fact, so much data we don't even need to call
4688                        filter_read.  */
4689                     take = umaxlen;
4690                 }
4691             } else {
4692                 const char *const first_nl =
4693                     (const char *)memchr(cache_p, '\n', cache_len);
4694                 if (first_nl) {
4695                     take = first_nl + 1 - cache_p;
4696                 }
4697             }
4698             if (take) {
4699                 sv_catpvn(buf_sv, cache_p, take);
4700                 sv_chop(cache, cache_p + take);
4701                 /* Definately not EOF  */
4702                 return 1;
4703             }
4704
4705             sv_catsv(buf_sv, cache);
4706             if (umaxlen) {
4707                 umaxlen -= cache_len;
4708             }
4709             SvOK_off(cache);
4710             read_from_cache = TRUE;
4711         }
4712     }
4713
4714     /* Filter API says that the filter appends to the contents of the buffer.
4715        Usually the buffer is "", so the details don't matter. But if it's not,
4716        then clearly what it contains is already filtered by this filter, so we
4717        don't want to pass it in a second time.
4718        I'm going to use a mortal in case the upstream filter croaks.  */
4719     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4720         ? sv_newmortal() : buf_sv;
4721     SvUPGRADE(upstream, SVt_PV);
4722
4723     if (filter_has_file) {
4724         status = FILTER_READ(idx+1, upstream, 0);
4725     }
4726
4727     if (filter_sub && status >= 0) {
4728         dSP;
4729         int count;
4730
4731         ENTER;
4732         SAVE_DEFSV;
4733         SAVETMPS;
4734         EXTEND(SP, 2);
4735
4736         DEFSV = upstream;
4737         PUSHMARK(SP);
4738         mPUSHi(0);
4739         if (filter_state) {
4740             PUSHs(filter_state);
4741         }
4742         PUTBACK;
4743         count = call_sv(filter_sub, G_SCALAR);
4744         SPAGAIN;
4745
4746         if (count > 0) {
4747             SV *out = POPs;
4748             if (SvOK(out)) {
4749                 status = SvIV(out);
4750             }
4751         }
4752
4753         PUTBACK;
4754         FREETMPS;
4755         LEAVE;
4756     }
4757
4758     if(SvOK(upstream)) {
4759         got_p = SvPV(upstream, got_len);
4760         if (umaxlen) {
4761             if (got_len > umaxlen) {
4762                 prune_from = got_p + umaxlen;
4763             }
4764         } else {
4765             const char *const first_nl =
4766                 (const char *)memchr(got_p, '\n', got_len);
4767             if (first_nl && first_nl + 1 < got_p + got_len) {
4768                 /* There's a second line here... */
4769                 prune_from = first_nl + 1;
4770             }
4771         }
4772     }
4773     if (prune_from) {
4774         /* Oh. Too long. Stuff some in our cache.  */
4775         STRLEN cached_len = got_p + got_len - prune_from;
4776         SV *cache = (SV *)IoFMT_GV(datasv);
4777
4778         if (!cache) {
4779             IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4780         } else if (SvOK(cache)) {
4781             /* Cache should be empty.  */
4782             assert(!SvCUR(cache));
4783         }
4784
4785         sv_setpvn(cache, prune_from, cached_len);
4786         /* If you ask for block mode, you may well split UTF-8 characters.
4787            "If it breaks, you get to keep both parts"
4788            (Your code is broken if you  don't put them back together again
4789            before something notices.) */
4790         if (SvUTF8(upstream)) {
4791             SvUTF8_on(cache);
4792         }
4793         SvCUR_set(upstream, got_len - cached_len);
4794         /* Can't yet be EOF  */
4795         if (status == 0)
4796             status = 1;
4797     }
4798
4799     /* If they are at EOF but buf_sv has something in it, then they may never
4800        have touched the SV upstream, so it may be undefined.  If we naively
4801        concatenate it then we get a warning about use of uninitialised value.
4802     */
4803     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4804         sv_catsv(buf_sv, upstream);
4805     }
4806
4807     if (status <= 0) {
4808         IoLINES(datasv) = 0;
4809         SvREFCNT_dec(IoFMT_GV(datasv));
4810         if (filter_state) {
4811             SvREFCNT_dec(filter_state);
4812             IoTOP_GV(datasv) = NULL;
4813         }
4814         if (filter_sub) {
4815             SvREFCNT_dec(filter_sub);
4816             IoBOTTOM_GV(datasv) = NULL;
4817         }
4818         filter_del(S_run_user_filter);
4819     }
4820     if (status == 0 && read_from_cache) {
4821         /* If we read some data from the cache (and by getting here it implies
4822            that we emptied the cache) then we aren't yet at EOF, and mustn't
4823            report that to our caller.  */
4824         return 1;
4825     }
4826     return status;
4827 }
4828
4829 /* perhaps someone can come up with a better name for
4830    this?  it is not really "absolute", per se ... */
4831 static bool
4832 S_path_is_absolute(const char *name)
4833 {
4834     if (PERL_FILE_IS_ABSOLUTE(name)
4835 #ifdef MACOS_TRADITIONAL
4836         || (*name == ':')
4837 #else
4838         || (*name == '.' && (name[1] == '/' ||
4839                              (name[1] == '.' && name[2] == '/')))
4840 #endif
4841          )
4842     {
4843         return TRUE;
4844     }
4845     else
4846         return FALSE;
4847 }
4848
4849 /*
4850  * Local variables:
4851  * c-indentation-style: bsd
4852  * c-basic-offset: 4
4853  * indent-tabs-mode: t
4854  * End:
4855  *
4856  * ex: set ts=8 sts=4 sw=4 noet:
4857  */