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