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