pp_ctl.c

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