pp_ctl.c

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