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