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