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