pp_ctl.c

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