pp_ctl.c

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