pp_ctl.c

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