pp_ctl.c

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