pp_ctl.c

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