pp_ctl.c

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