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