pp_ctl.c

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