pp_ctl.c

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