pp_ctl.c

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