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