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