pp_ctl.c

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