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;
1138             const char *tmps = SvPV(final, len);
1139
1140             sv = sv_mortalcopy(left);
1141             SvPV_force_nolen(sv);
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                 cx->blk_loop.iterlval = newSVsv(sv);
1835                 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1836                 (void) SvPV_nolen_const(right);
1837             }
1838         }
1839         else if (PL_op->op_private & OPpITER_REVERSED) {
1840             cx->blk_loop.itermax = -1;
1841             cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1842
1843         }
1844     }
1845     else {
1846         cx->blk_loop.iterary = PL_curstack;
1847         AvFILLp(PL_curstack) = SP - PL_stack_base;
1848         if (PL_op->op_private & OPpITER_REVERSED) {
1849             cx->blk_loop.itermax = MARK - PL_stack_base;
1850             cx->blk_loop.iterix = cx->blk_oldsp;
1851         }
1852         else {
1853             cx->blk_loop.iterix = MARK - PL_stack_base;
1854         }
1855     }
1856
1857     RETURN;
1858 }
1859
1860 PP(pp_enterloop)
1861 {
1862     dVAR; dSP;
1863     register PERL_CONTEXT *cx;
1864     const I32 gimme = GIMME_V;
1865
1866     ENTER;
1867     SAVETMPS;
1868     ENTER;
1869
1870     PUSHBLOCK(cx, CXt_LOOP, SP);
1871     PUSHLOOP(cx, 0, SP);
1872
1873     RETURN;
1874 }
1875
1876 PP(pp_leaveloop)
1877 {
1878     dVAR; dSP;
1879     register PERL_CONTEXT *cx;
1880     I32 gimme;
1881     SV **newsp;
1882     PMOP *newpm;
1883     SV **mark;
1884
1885     POPBLOCK(cx,newpm);
1886     assert(CxTYPE(cx) == CXt_LOOP);
1887     mark = newsp;
1888     newsp = PL_stack_base + cx->blk_loop.resetsp;
1889
1890     TAINT_NOT;
1891     if (gimme == G_VOID)
1892         ; /* do nothing */
1893     else if (gimme == G_SCALAR) {
1894         if (mark < SP)
1895             *++newsp = sv_mortalcopy(*SP);
1896         else
1897             *++newsp = &PL_sv_undef;
1898     }
1899     else {
1900         while (mark < SP) {
1901             *++newsp = sv_mortalcopy(*++mark);
1902             TAINT_NOT;          /* Each item is independent */
1903         }
1904     }
1905     SP = newsp;
1906     PUTBACK;
1907
1908     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1909     PL_curpm = newpm;   /* ... and pop $1 et al */
1910
1911     LEAVE;
1912     LEAVE;
1913
1914     return NORMAL;
1915 }
1916
1917 PP(pp_return)
1918 {
1919     dVAR; dSP; dMARK;
1920     I32 cxix;
1921     register PERL_CONTEXT *cx;
1922     bool popsub2 = FALSE;
1923     bool clear_errsv = FALSE;
1924     I32 gimme;
1925     SV **newsp;
1926     PMOP *newpm;
1927     I32 optype = 0;
1928     SV *sv;
1929     OP *retop;
1930
1931     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1932         if (cxstack_ix == PL_sortcxix
1933             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1934         {
1935             if (cxstack_ix > PL_sortcxix)
1936                 dounwind(PL_sortcxix);
1937             AvARRAY(PL_curstack)[1] = *SP;
1938             PL_stack_sp = PL_stack_base + 1;
1939             return 0;
1940         }
1941     }
1942
1943     cxix = dopoptosub(cxstack_ix);
1944     if (cxix < 0)
1945         DIE(aTHX_ "Can't return outside a subroutine");
1946     if (cxix < cxstack_ix)
1947         dounwind(cxix);
1948
1949     POPBLOCK(cx,newpm);
1950     switch (CxTYPE(cx)) {
1951     case CXt_SUB:
1952         popsub2 = TRUE;
1953         retop = cx->blk_sub.retop;
1954         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1955         break;
1956     case CXt_EVAL:
1957         if (!(PL_in_eval & EVAL_KEEPERR))
1958             clear_errsv = TRUE;
1959         POPEVAL(cx);
1960         retop = cx->blk_eval.retop;
1961         if (CxTRYBLOCK(cx))
1962             break;
1963         lex_end();
1964         if (optype == OP_REQUIRE &&
1965             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1966         {
1967             /* Unassume the success we assumed earlier. */
1968             SV *nsv = cx->blk_eval.old_namesv;
1969             (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
1970             DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1971         }
1972         break;
1973     case CXt_FORMAT:
1974         POPFORMAT(cx);
1975         retop = cx->blk_sub.retop;
1976         break;
1977     default:
1978         DIE(aTHX_ "panic: return");
1979     }
1980
1981     TAINT_NOT;
1982     if (gimme == G_SCALAR) {
1983         if (MARK < SP) {
1984             if (popsub2) {
1985                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1986                     if (SvTEMP(TOPs)) {
1987                         *++newsp = SvREFCNT_inc(*SP);
1988                         FREETMPS;
1989                         sv_2mortal(*newsp);
1990                     }
1991                     else {
1992                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1993                         FREETMPS;
1994                         *++newsp = sv_mortalcopy(sv);
1995                         SvREFCNT_dec(sv);
1996                     }
1997                 }
1998                 else
1999                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2000             }
2001             else
2002                 *++newsp = sv_mortalcopy(*SP);
2003         }
2004         else
2005             *++newsp = &PL_sv_undef;
2006     }
2007     else if (gimme == G_ARRAY) {
2008         while (++MARK <= SP) {
2009             *++newsp = (popsub2 && SvTEMP(*MARK))
2010                         ? *MARK : sv_mortalcopy(*MARK);
2011             TAINT_NOT;          /* Each item is independent */
2012         }
2013     }
2014     PL_stack_sp = newsp;
2015
2016     LEAVE;
2017     /* Stack values are safe: */
2018     if (popsub2) {
2019         cxstack_ix--;
2020         POPSUB(cx,sv);  /* release CV and @_ ... */
2021     }
2022     else
2023         sv = Nullsv;
2024     PL_curpm = newpm;   /* ... and pop $1 et al */
2025
2026     LEAVESUB(sv);
2027     if (clear_errsv)
2028         sv_setpvn(ERRSV,"",0);
2029     return retop;
2030 }
2031
2032 PP(pp_last)
2033 {
2034     dVAR; dSP;
2035     I32 cxix;
2036     register PERL_CONTEXT *cx;
2037     I32 pop2 = 0;
2038     I32 gimme;
2039     I32 optype;
2040     OP *nextop;
2041     SV **newsp;
2042     PMOP *newpm;
2043     SV **mark;
2044     SV *sv = Nullsv;
2045
2046     if (PL_op->op_flags & OPf_SPECIAL) {
2047         cxix = dopoptoloop(cxstack_ix);
2048         if (cxix < 0)
2049             DIE(aTHX_ "Can't \"last\" outside a loop block");
2050     }
2051     else {
2052         cxix = dopoptolabel(cPVOP->op_pv);
2053         if (cxix < 0)
2054             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2055     }
2056     if (cxix < cxstack_ix)
2057         dounwind(cxix);
2058
2059     POPBLOCK(cx,newpm);
2060     cxstack_ix++; /* temporarily protect top context */
2061     mark = newsp;
2062     switch (CxTYPE(cx)) {
2063     case CXt_LOOP:
2064         pop2 = CXt_LOOP;
2065         newsp = PL_stack_base + cx->blk_loop.resetsp;
2066         nextop = cx->blk_loop.last_op->op_next;
2067         break;
2068     case CXt_SUB:
2069         pop2 = CXt_SUB;
2070         nextop = cx->blk_sub.retop;
2071         break;
2072     case CXt_EVAL:
2073         POPEVAL(cx);
2074         nextop = cx->blk_eval.retop;
2075         break;
2076     case CXt_FORMAT:
2077         POPFORMAT(cx);
2078         nextop = cx->blk_sub.retop;
2079         break;
2080     default:
2081         DIE(aTHX_ "panic: last");
2082     }
2083
2084     TAINT_NOT;
2085     if (gimme == G_SCALAR) {
2086         if (MARK < SP)
2087             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2088                         ? *SP : sv_mortalcopy(*SP);
2089         else
2090             *++newsp = &PL_sv_undef;
2091     }
2092     else if (gimme == G_ARRAY) {
2093         while (++MARK <= SP) {
2094             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2095                         ? *MARK : sv_mortalcopy(*MARK);
2096             TAINT_NOT;          /* Each item is independent */
2097         }
2098     }
2099     SP = newsp;
2100     PUTBACK;
2101
2102     LEAVE;
2103     cxstack_ix--;
2104     /* Stack values are safe: */
2105     switch (pop2) {
2106     case CXt_LOOP:
2107         POPLOOP(cx);    /* release loop vars ... */
2108         LEAVE;
2109         break;
2110     case CXt_SUB:
2111         POPSUB(cx,sv);  /* release CV and @_ ... */
2112         break;
2113     }
2114     PL_curpm = newpm;   /* ... and pop $1 et al */
2115
2116     LEAVESUB(sv);
2117     return nextop;
2118 }
2119
2120 PP(pp_next)
2121 {
2122     dVAR;
2123     I32 cxix;
2124     register PERL_CONTEXT *cx;
2125     I32 inner;
2126
2127     if (PL_op->op_flags & OPf_SPECIAL) {
2128         cxix = dopoptoloop(cxstack_ix);
2129         if (cxix < 0)
2130             DIE(aTHX_ "Can't \"next\" outside a loop block");
2131     }
2132     else {
2133         cxix = dopoptolabel(cPVOP->op_pv);
2134         if (cxix < 0)
2135             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2136     }
2137     if (cxix < cxstack_ix)
2138         dounwind(cxix);
2139
2140     /* clear off anything above the scope we're re-entering, but
2141      * save the rest until after a possible continue block */
2142     inner = PL_scopestack_ix;
2143     TOPBLOCK(cx);
2144     if (PL_scopestack_ix < inner)
2145         leave_scope(PL_scopestack[PL_scopestack_ix]);
2146     PL_curcop = cx->blk_oldcop;
2147     return cx->blk_loop.next_op;
2148 }
2149
2150 PP(pp_redo)
2151 {
2152     dVAR;
2153     I32 cxix;
2154     register PERL_CONTEXT *cx;
2155     I32 oldsave;
2156     OP* redo_op;
2157
2158     if (PL_op->op_flags & OPf_SPECIAL) {
2159         cxix = dopoptoloop(cxstack_ix);
2160         if (cxix < 0)
2161             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2162     }
2163     else {
2164         cxix = dopoptolabel(cPVOP->op_pv);
2165         if (cxix < 0)
2166             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2167     }
2168     if (cxix < cxstack_ix)
2169         dounwind(cxix);
2170
2171     redo_op = cxstack[cxix].blk_loop.redo_op;
2172     if (redo_op->op_type == OP_ENTER) {
2173         /* pop one less context to avoid $x being freed in while (my $x..) */
2174         cxstack_ix++;
2175         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2176         redo_op = redo_op->op_next;
2177     }
2178
2179     TOPBLOCK(cx);
2180     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2181     LEAVE_SCOPE(oldsave);
2182     FREETMPS;
2183     PL_curcop = cx->blk_oldcop;
2184     return redo_op;
2185 }
2186
2187 STATIC OP *
2188 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2189 {
2190     OP *kid = Nullop;
2191     OP **ops = opstack;
2192     static const char too_deep[] = "Target of goto is too deeply nested";
2193
2194     if (ops >= oplimit)
2195         Perl_croak(aTHX_ too_deep);
2196     if (o->op_type == OP_LEAVE ||
2197         o->op_type == OP_SCOPE ||
2198         o->op_type == OP_LEAVELOOP ||
2199         o->op_type == OP_LEAVESUB ||
2200         o->op_type == OP_LEAVETRY)
2201     {
2202         *ops++ = cUNOPo->op_first;
2203         if (ops >= oplimit)
2204             Perl_croak(aTHX_ too_deep);
2205     }
2206     *ops = 0;
2207     if (o->op_flags & OPf_KIDS) {
2208         /* First try all the kids at this level, since that's likeliest. */
2209         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2210             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2211                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2212                 return kid;
2213         }
2214         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2215             if (kid == PL_lastgotoprobe)
2216                 continue;
2217             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2218                 if (ops == opstack)
2219                     *ops++ = kid;
2220                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2221                          ops[-1]->op_type == OP_DBSTATE)
2222                     ops[-1] = kid;
2223                 else
2224                     *ops++ = kid;
2225             }
2226             if ((o = dofindlabel(kid, label, ops, oplimit)))
2227                 return o;
2228         }
2229     }
2230     *ops = 0;
2231     return 0;
2232 }
2233
2234 PP(pp_dump)
2235 {
2236     return pp_goto();
2237     /*NOTREACHED*/
2238 }
2239
2240 PP(pp_goto)
2241 {
2242     dVAR; dSP;
2243     OP *retop = 0;
2244     I32 ix;
2245     register PERL_CONTEXT *cx;
2246 #define GOTO_DEPTH 64
2247     OP *enterops[GOTO_DEPTH];
2248     const char *label = 0;
2249     const bool do_dump = (PL_op->op_type == OP_DUMP);
2250     static const char must_have_label[] = "goto must have label";
2251
2252     if (PL_op->op_flags & OPf_STACKED) {
2253         SV *sv = POPs;
2254
2255         /* This egregious kludge implements goto &subroutine */
2256         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2257             I32 cxix;
2258             register PERL_CONTEXT *cx;
2259             CV* cv = (CV*)SvRV(sv);
2260             SV** mark;
2261             I32 items = 0;
2262             I32 oldsave;
2263             bool reified = 0;
2264
2265         retry:
2266             if (!CvROOT(cv) && !CvXSUB(cv)) {
2267                 const GV * const gv = CvGV(cv);
2268                 if (gv) {
2269                     GV *autogv;
2270                     SV *tmpstr;
2271                     /* autoloaded stub? */
2272                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2273                         goto retry;
2274                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2275                                           GvNAMELEN(gv), FALSE);
2276                     if (autogv && (cv = GvCV(autogv)))
2277                         goto retry;
2278                     tmpstr = sv_newmortal();
2279                     gv_efullname3(tmpstr, gv, Nullch);
2280                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2281                 }
2282                 DIE(aTHX_ "Goto undefined subroutine");
2283             }
2284
2285             /* First do some returnish stuff. */
2286             (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2287             FREETMPS;
2288             cxix = dopoptosub(cxstack_ix);
2289             if (cxix < 0)
2290                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2291             if (cxix < cxstack_ix)
2292                 dounwind(cxix);
2293             TOPBLOCK(cx);
2294             SPAGAIN;
2295             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2296             if (CxTYPE(cx) == CXt_EVAL) {
2297                 if (CxREALEVAL(cx))
2298                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2299                 else
2300                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2301             }
2302             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2303                 /* put @_ back onto stack */
2304                 AV* av = cx->blk_sub.argarray;
2305
2306                 items = AvFILLp(av) + 1;
2307                 EXTEND(SP, items+1); /* @_ could have been extended. */
2308                 Copy(AvARRAY(av), SP + 1, items, SV*);
2309                 SvREFCNT_dec(GvAV(PL_defgv));
2310                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2311                 CLEAR_ARGARRAY(av);
2312                 /* abandon @_ if it got reified */
2313                 if (AvREAL(av)) {
2314                     reified = 1;
2315                     SvREFCNT_dec(av);
2316                     av = newAV();
2317                     av_extend(av, items-1);
2318                     AvREIFY_only(av);
2319                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2320                 }
2321             }
2322             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2323                 AV* av;
2324                 av = GvAV(PL_defgv);
2325                 items = AvFILLp(av) + 1;
2326                 EXTEND(SP, items+1); /* @_ could have been extended. */
2327                 Copy(AvARRAY(av), SP + 1, items, SV*);
2328             }
2329             mark = SP;
2330             SP += items;
2331             if (CxTYPE(cx) == CXt_SUB &&
2332                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2333                 SvREFCNT_dec(cx->blk_sub.cv);
2334             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2335             LEAVE_SCOPE(oldsave);
2336
2337             /* Now do some callish stuff. */
2338             SAVETMPS;
2339             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2340             if (CvXSUB(cv)) {
2341                 OP* retop = cx->blk_sub.retop;
2342                 if (reified) {
2343                     I32 index;
2344                     for (index=0; index<items; index++)
2345                         sv_2mortal(SP[-index]);
2346                 }
2347 #ifdef PERL_XSUB_OLDSTYLE
2348                 if (CvOLDSTYLE(cv)) {
2349                     I32 (*fp3)(int,int,int);
2350                     while (SP > mark) {
2351                         SP[1] = SP[0];
2352                         SP--;
2353                     }
2354                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2355                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2356                                    mark - PL_stack_base + 1,
2357                                    items);
2358                     SP = PL_stack_base + items;
2359                 }
2360                 else
2361 #endif /* PERL_XSUB_OLDSTYLE */
2362                 {
2363                     SV **newsp;
2364                     I32 gimme;
2365
2366                     /* XS subs don't have a CxSUB, so pop it */
2367                     POPBLOCK(cx, PL_curpm);
2368                     /* Push a mark for the start of arglist */
2369                     PUSHMARK(mark);
2370                     PUTBACK;
2371                     (void)(*CvXSUB(cv))(aTHX_ cv);
2372                 }
2373                 LEAVE;
2374                 return retop;
2375             }
2376             else {
2377                 AV* padlist = CvPADLIST(cv);
2378                 if (CxTYPE(cx) == CXt_EVAL) {
2379                     PL_in_eval = cx->blk_eval.old_in_eval;
2380                     PL_eval_root = cx->blk_eval.old_eval_root;
2381                     cx->cx_type = CXt_SUB;
2382                     cx->blk_sub.hasargs = 0;
2383                 }
2384                 cx->blk_sub.cv = cv;
2385                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2386
2387                 CvDEPTH(cv)++;
2388                 if (CvDEPTH(cv) < 2)
2389                     (void)SvREFCNT_inc(cv);
2390                 else {
2391                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2392                         sub_crush_depth(cv);
2393                     pad_push(padlist, CvDEPTH(cv));
2394                 }
2395                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2396                 if (cx->blk_sub.hasargs)
2397                 {
2398                     AV* av = (AV*)PAD_SVl(0);
2399                     SV** ary;
2400
2401                     cx->blk_sub.savearray = GvAV(PL_defgv);
2402                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2403                     CX_CURPAD_SAVE(cx->blk_sub);
2404                     cx->blk_sub.argarray = av;
2405
2406                     if (items >= AvMAX(av) + 1) {
2407                         ary = AvALLOC(av);
2408                         if (AvARRAY(av) != ary) {
2409                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2410                             SvPV_set(av, (char*)ary);
2411                         }
2412                         if (items >= AvMAX(av) + 1) {
2413                             AvMAX(av) = items - 1;
2414                             Renew(ary,items+1,SV*);
2415                             AvALLOC(av) = ary;
2416                             SvPV_set(av, (char*)ary);
2417                         }
2418                     }
2419                     ++mark;
2420                     Copy(mark,AvARRAY(av),items,SV*);
2421                     AvFILLp(av) = items - 1;
2422                     assert(!AvREAL(av));
2423                     if (reified) {
2424                         /* transfer 'ownership' of refcnts to new @_ */
2425                         AvREAL_on(av);
2426                         AvREIFY_off(av);
2427                     }
2428                     while (items--) {
2429                         if (*mark)
2430                             SvTEMP_off(*mark);
2431                         mark++;
2432                     }
2433                 }
2434                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2435                     /*
2436                      * We do not care about using sv to call CV;
2437                      * it's for informational purposes only.
2438                      */
2439                     SV *sv = GvSV(PL_DBsub);
2440                     CV *gotocv;
2441
2442                     save_item(sv);
2443                     if (PERLDB_SUB_NN) {
2444                         int type = SvTYPE(sv);
2445                         if (type < SVt_PVIV && type != SVt_IV)
2446                             sv_upgrade(sv, SVt_PVIV);
2447                         (void)SvIOK_on(sv);
2448                         SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2449                     } else {
2450                         gv_efullname3(sv, CvGV(cv), Nullch);
2451                     }
2452                     if (  PERLDB_GOTO
2453                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2454                         PUSHMARK( PL_stack_sp );
2455                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2456                         PL_stack_sp--;
2457                     }
2458                 }
2459                 RETURNOP(CvSTART(cv));
2460             }
2461         }
2462         else {
2463             label = SvPV_nolen_const(sv);
2464             if (!(do_dump || *label))
2465                 DIE(aTHX_ must_have_label);
2466         }
2467     }
2468     else if (PL_op->op_flags & OPf_SPECIAL) {
2469         if (! do_dump)
2470             DIE(aTHX_ must_have_label);
2471     }
2472     else
2473         label = cPVOP->op_pv;
2474
2475     if (label && *label) {
2476         OP *gotoprobe = 0;
2477         bool leaving_eval = FALSE;
2478         bool in_block = FALSE;
2479         PERL_CONTEXT *last_eval_cx = 0;
2480
2481         /* find label */
2482
2483         PL_lastgotoprobe = 0;
2484         *enterops = 0;
2485         for (ix = cxstack_ix; ix >= 0; ix--) {
2486             cx = &cxstack[ix];
2487             switch (CxTYPE(cx)) {
2488             case CXt_EVAL:
2489                 leaving_eval = TRUE;
2490                 if (!CxTRYBLOCK(cx)) {
2491                     gotoprobe = (last_eval_cx ?
2492                                 last_eval_cx->blk_eval.old_eval_root :
2493                                 PL_eval_root);
2494                     last_eval_cx = cx;
2495                     break;
2496                 }
2497                 /* else fall through */
2498             case CXt_LOOP:
2499                 gotoprobe = cx->blk_oldcop->op_sibling;
2500                 break;
2501             case CXt_SUBST:
2502                 continue;
2503             case CXt_BLOCK:
2504                 if (ix) {
2505                     gotoprobe = cx->blk_oldcop->op_sibling;
2506                     in_block = TRUE;
2507                 } else
2508                     gotoprobe = PL_main_root;
2509                 break;
2510             case CXt_SUB:
2511                 if (CvDEPTH(cx->blk_sub.cv)) {
2512                     gotoprobe = CvROOT(cx->blk_sub.cv);
2513                     break;
2514                 }
2515                 /* FALL THROUGH */
2516             case CXt_FORMAT:
2517             case CXt_NULL:
2518                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2519             default:
2520                 if (ix)
2521                     DIE(aTHX_ "panic: goto");
2522                 gotoprobe = PL_main_root;
2523                 break;
2524             }
2525             if (gotoprobe) {
2526                 retop = dofindlabel(gotoprobe, label,
2527                                     enterops, enterops + GOTO_DEPTH);
2528                 if (retop)
2529                     break;
2530             }
2531             PL_lastgotoprobe = gotoprobe;
2532         }
2533         if (!retop)
2534             DIE(aTHX_ "Can't find label %s", label);
2535
2536         /* if we're leaving an eval, check before we pop any frames
2537            that we're not going to punt, otherwise the error
2538            won't be caught */
2539
2540         if (leaving_eval && *enterops && enterops[1]) {
2541             I32 i;
2542             for (i = 1; enterops[i]; i++)
2543                 if (enterops[i]->op_type == OP_ENTERITER)
2544                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2545         }
2546
2547         /* pop unwanted frames */
2548
2549         if (ix < cxstack_ix) {
2550             I32 oldsave;
2551
2552             if (ix < 0)
2553                 ix = 0;
2554             dounwind(ix);
2555             TOPBLOCK(cx);
2556             oldsave = PL_scopestack[PL_scopestack_ix];
2557             LEAVE_SCOPE(oldsave);
2558         }
2559
2560         /* push wanted frames */
2561
2562         if (*enterops && enterops[1]) {
2563             OP *oldop = PL_op;
2564             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2565             for (; enterops[ix]; ix++) {
2566                 PL_op = enterops[ix];
2567                 /* Eventually we may want to stack the needed arguments
2568                  * for each op.  For now, we punt on the hard ones. */
2569                 if (PL_op->op_type == OP_ENTERITER)
2570                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2571                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2572             }
2573             PL_op = oldop;
2574         }
2575     }
2576
2577     if (do_dump) {
2578 #ifdef VMS
2579         if (!retop) retop = PL_main_start;
2580 #endif
2581         PL_restartop = retop;
2582         PL_do_undump = TRUE;
2583
2584         my_unexec();
2585
2586         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2587         PL_do_undump = FALSE;
2588     }
2589
2590     RETURNOP(retop);
2591 }
2592
2593 PP(pp_exit)
2594 {
2595     dSP;
2596     I32 anum;
2597
2598     if (MAXARG < 1)
2599         anum = 0;
2600     else {
2601         anum = SvIVx(POPs);
2602 #ifdef VMS
2603         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2604             anum = 0;
2605         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2606 #endif
2607     }
2608     PL_exit_flags |= PERL_EXIT_EXPECTED;
2609     my_exit(anum);
2610     PUSHs(&PL_sv_undef);
2611     RETURN;
2612 }
2613
2614 #ifdef NOTYET
2615 PP(pp_nswitch)
2616 {
2617     dSP;
2618     const NV value = SvNVx(GvSV(cCOP->cop_gv));
2619     register I32 match = I_32(value);
2620
2621     if (value < 0.0) {
2622         if (((NV)match) > value)
2623             --match;            /* was fractional--truncate other way */
2624     }
2625     match -= cCOP->uop.scop.scop_offset;
2626     if (match < 0)
2627         match = 0;
2628     else if (match > cCOP->uop.scop.scop_max)
2629         match = cCOP->uop.scop.scop_max;
2630     PL_op = cCOP->uop.scop.scop_next[match];
2631     RETURNOP(PL_op);
2632 }
2633
2634 PP(pp_cswitch)
2635 {
2636     dSP;
2637     register I32 match;
2638
2639     if (PL_multiline)
2640         PL_op = PL_op->op_next;                 /* can't assume anything */
2641     else {
2642         match = *(SvPVx_nolen_const(GvSV(cCOP->cop_gv))) & 255;
2643         match -= cCOP->uop.scop.scop_offset;
2644         if (match < 0)
2645             match = 0;
2646         else if (match > cCOP->uop.scop.scop_max)
2647             match = cCOP->uop.scop.scop_max;
2648         PL_op = cCOP->uop.scop.scop_next[match];
2649     }
2650     RETURNOP(PL_op);
2651 }
2652 #endif
2653
2654 /* Eval. */
2655
2656 STATIC void
2657 S_save_lines(pTHX_ AV *array, SV *sv)
2658 {
2659     const char *s = SvPVX_const(sv);
2660     const char *send = SvPVX_const(sv) + SvCUR(sv);
2661     I32 line = 1;
2662
2663     while (s && s < send) {
2664         const char *t;
2665         SV *tmpstr = NEWSV(85,0);
2666
2667         sv_upgrade(tmpstr, SVt_PVMG);
2668         t = strchr(s, '\n');
2669         if (t)
2670             t++;
2671         else
2672             t = send;
2673
2674         sv_setpvn(tmpstr, s, t - s);
2675         av_store(array, line++, tmpstr);
2676         s = t;
2677     }
2678 }
2679
2680 STATIC void *
2681 S_docatch_body(pTHX)
2682 {
2683     CALLRUNOPS(aTHX);
2684     return NULL;
2685 }
2686
2687 STATIC OP *
2688 S_docatch(pTHX_ OP *o)
2689 {
2690     int ret;
2691     OP * const oldop = PL_op;
2692     dJMPENV;
2693
2694 #ifdef DEBUGGING
2695     assert(CATCH_GET == TRUE);
2696 #endif
2697     PL_op = o;
2698
2699     JMPENV_PUSH(ret);
2700     switch (ret) {
2701     case 0:
2702         assert(cxstack_ix >= 0);
2703         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2704         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2705  redo_body:
2706         docatch_body();
2707         break;
2708     case 3:
2709         /* die caught by an inner eval - continue inner loop */
2710
2711         /* NB XXX we rely on the old popped CxEVAL still being at the top
2712          * of the stack; the way die_where() currently works, this
2713          * assumption is valid. In theory The cur_top_env value should be
2714          * returned in another global, the way retop (aka PL_restartop)
2715          * is. */
2716         assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2717
2718         if (PL_restartop
2719             && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2720         {
2721             PL_op = PL_restartop;
2722             PL_restartop = 0;
2723             goto redo_body;
2724         }
2725         /* FALL THROUGH */
2726     default:
2727         JMPENV_POP;
2728         PL_op = oldop;
2729         JMPENV_JUMP(ret);
2730         /* NOTREACHED */
2731     }
2732     JMPENV_POP;
2733     PL_op = oldop;
2734     return Nullop;
2735 }
2736
2737 OP *
2738 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2739 /* sv Text to convert to OP tree. */
2740 /* startop op_free() this to undo. */
2741 /* code Short string id of the caller. */
2742 {
2743     dVAR; dSP;                          /* Make POPBLOCK work. */
2744     PERL_CONTEXT *cx;
2745     SV **newsp;
2746     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2747     I32 optype;
2748     OP dummy;
2749     OP *rop;
2750     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2751     char *tmpbuf = tbuf;
2752     char *safestr;
2753     int runtime;
2754     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2755
2756     ENTER;
2757     lex_start(sv);
2758     SAVETMPS;
2759     /* switch to eval mode */
2760
2761     if (IN_PERL_COMPILETIME) {
2762         SAVECOPSTASH_FREE(&PL_compiling);
2763         CopSTASH_set(&PL_compiling, PL_curstash);
2764     }
2765     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2766         SV *sv = sv_newmortal();
2767         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2768                        code, (unsigned long)++PL_evalseq,
2769                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2770         tmpbuf = SvPVX(sv);
2771     }
2772     else
2773         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2774     SAVECOPFILE_FREE(&PL_compiling);
2775     CopFILE_set(&PL_compiling, tmpbuf+2);
2776     SAVECOPLINE(&PL_compiling);
2777     CopLINE_set(&PL_compiling, 1);
2778     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2779        deleting the eval's FILEGV from the stash before gv_check() runs
2780        (i.e. before run-time proper). To work around the coredump that
2781        ensues, we always turn GvMULTI_on for any globals that were
2782        introduced within evals. See force_ident(). GSAR 96-10-12 */
2783     safestr = savepv(tmpbuf);
2784     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2785     SAVEHINTS();
2786 #ifdef OP_IN_REGISTER
2787     PL_opsave = op;
2788 #else
2789     SAVEVPTR(PL_op);
2790 #endif
2791
2792     /* we get here either during compilation, or via pp_regcomp at runtime */
2793     runtime = IN_PERL_RUNTIME;
2794     if (runtime)
2795         runcv = find_runcv(NULL);
2796
2797     PL_op = &dummy;
2798     PL_op->op_type = OP_ENTEREVAL;
2799     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2800     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2801     PUSHEVAL(cx, 0, Nullgv);
2802
2803     if (runtime)
2804         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2805     else
2806         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2807     POPBLOCK(cx,PL_curpm);
2808     POPEVAL(cx);
2809
2810     (*startop)->op_type = OP_NULL;
2811     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2812     lex_end();
2813     /* XXX DAPM do this properly one year */
2814     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2815     LEAVE;
2816     if (IN_PERL_COMPILETIME)
2817         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2818 #ifdef OP_IN_REGISTER
2819     op = PL_opsave;
2820 #endif
2821     return rop;
2822 }
2823
2824
2825 /*
2826 =for apidoc find_runcv
2827
2828 Locate the CV corresponding to the currently executing sub or eval.
2829 If db_seqp is non_null, skip CVs that are in the DB package and populate
2830 *db_seqp with the cop sequence number at the point that the DB:: code was
2831 entered. (allows debuggers to eval in the scope of the breakpoint rather
2832 than in in the scope of the debugger itself).
2833
2834 =cut
2835 */
2836
2837 CV*
2838 Perl_find_runcv(pTHX_ U32 *db_seqp)
2839 {
2840     PERL_SI      *si;
2841
2842     if (db_seqp)
2843         *db_seqp = PL_curcop->cop_seq;
2844     for (si = PL_curstackinfo; si; si = si->si_prev) {
2845         I32 ix;
2846         for (ix = si->si_cxix; ix >= 0; ix--) {
2847             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2848             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2849                 CV *cv = cx->blk_sub.cv;
2850                 /* skip DB:: code */
2851                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2852                     *db_seqp = cx->blk_oldcop->cop_seq;
2853                     continue;
2854                 }
2855                 return cv;
2856             }
2857             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2858                 return PL_compcv;
2859         }
2860     }
2861     return PL_main_cv;
2862 }
2863
2864
2865 /* Compile a require/do, an eval '', or a /(?{...})/.
2866  * In the last case, startop is non-null, and contains the address of
2867  * a pointer that should be set to the just-compiled code.
2868  * outside is the lexically enclosing CV (if any) that invoked us.
2869  */
2870
2871 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2872 STATIC OP *
2873 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2874 {
2875     dVAR; dSP;
2876     OP *saveop = PL_op;
2877
2878     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2879                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2880                   : EVAL_INEVAL);
2881
2882     PUSHMARK(SP);
2883
2884     SAVESPTR(PL_compcv);
2885     PL_compcv = (CV*)NEWSV(1104,0);
2886     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2887     CvEVAL_on(PL_compcv);
2888     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2889     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2890
2891     CvOUTSIDE_SEQ(PL_compcv) = seq;
2892     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2893
2894     /* set up a scratch pad */
2895
2896     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2897
2898
2899     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2900
2901     /* make sure we compile in the right package */
2902
2903     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2904         SAVESPTR(PL_curstash);
2905         PL_curstash = CopSTASH(PL_curcop);
2906     }
2907     SAVESPTR(PL_beginav);
2908     PL_beginav = newAV();
2909     SAVEFREESV(PL_beginav);
2910     SAVEI32(PL_error_count);
2911
2912     /* try to compile it */
2913
2914     PL_eval_root = Nullop;
2915     PL_error_count = 0;
2916     PL_curcop = &PL_compiling;
2917     PL_curcop->cop_arybase = 0;
2918     if (saveop && saveop->op_flags & OPf_SPECIAL)
2919         PL_in_eval |= EVAL_KEEPERR;
2920     else
2921         sv_setpvn(ERRSV,"",0);
2922     if (yyparse() || PL_error_count || !PL_eval_root) {
2923         SV **newsp;                     /* Used by POPBLOCK. */
2924        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2925         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2926
2927         PL_op = saveop;
2928         if (PL_eval_root) {
2929             op_free(PL_eval_root);
2930             PL_eval_root = Nullop;
2931         }
2932         SP = PL_stack_base + POPMARK;           /* pop original mark */
2933         if (!startop) {
2934             POPBLOCK(cx,PL_curpm);
2935             POPEVAL(cx);
2936         }
2937         lex_end();
2938         LEAVE;
2939         if (optype == OP_REQUIRE) {
2940             const char* const msg = SvPVx_nolen_const(ERRSV);
2941             const SV * const nsv = cx->blk_eval.old_namesv;
2942             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2943                           &PL_sv_undef, 0);
2944             DIE(aTHX_ "%sCompilation failed in require",
2945                 *msg ? msg : "Unknown error\n");
2946         }
2947         else if (startop) {
2948             const char* msg = SvPVx_nolen_const(ERRSV);
2949
2950             POPBLOCK(cx,PL_curpm);
2951             POPEVAL(cx);
2952             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2953                        (*msg ? msg : "Unknown error\n"));
2954         }
2955         else {
2956             const char* msg = SvPVx_nolen_const(ERRSV);
2957             if (!*msg) {
2958                 sv_setpv(ERRSV, "Compilation error");
2959             }
2960         }
2961         RETPUSHUNDEF;
2962     }
2963     CopLINE_set(&PL_compiling, 0);
2964     if (startop) {
2965         *startop = PL_eval_root;
2966     } else
2967         SAVEFREEOP(PL_eval_root);
2968
2969     /* Set the context for this new optree.
2970      * If the last op is an OP_REQUIRE, force scalar context.
2971      * Otherwise, propagate the context from the eval(). */
2972     if (PL_eval_root->op_type == OP_LEAVEEVAL
2973             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2974             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2975             == OP_REQUIRE)
2976         scalar(PL_eval_root);
2977     else if (gimme & G_VOID)
2978         scalarvoid(PL_eval_root);
2979     else if (gimme & G_ARRAY)
2980         list(PL_eval_root);
2981     else
2982         scalar(PL_eval_root);
2983
2984     DEBUG_x(dump_eval());
2985
2986     /* Register with debugger: */
2987     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2988         CV *cv = get_cv("DB::postponed", FALSE);
2989         if (cv) {
2990             dSP;
2991             PUSHMARK(SP);
2992             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2993             PUTBACK;
2994             call_sv((SV*)cv, G_DISCARD);
2995         }
2996     }
2997
2998     /* compiled okay, so do it */
2999
3000     CvDEPTH(PL_compcv) = 1;
3001     SP = PL_stack_base + POPMARK;               /* pop original mark */
3002     PL_op = saveop;                     /* The caller may need it. */
3003     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3004
3005     RETURNOP(PL_eval_start);
3006 }
3007
3008 STATIC PerlIO *
3009 S_doopen_pm(pTHX_ const char *name, const char *mode)
3010 {
3011 #ifndef PERL_DISABLE_PMC
3012     const STRLEN namelen = strlen(name);
3013     PerlIO *fp;
3014
3015     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3016         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3017         const char * const pmc = SvPV_nolen(pmcsv);
3018         Stat_t pmstat;
3019         Stat_t pmcstat;
3020         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3021             fp = PerlIO_open(name, mode);
3022         }
3023         else {
3024             if (PerlLIO_stat(name, &pmstat) < 0 ||
3025                 pmstat.st_mtime < pmcstat.st_mtime)
3026             {
3027                 fp = PerlIO_open(pmc, mode);
3028             }
3029             else {
3030                 fp = PerlIO_open(name, mode);
3031             }
3032         }
3033         SvREFCNT_dec(pmcsv);
3034     }
3035     else {
3036         fp = PerlIO_open(name, mode);
3037     }
3038     return fp;
3039 #else
3040     return PerlIO_open(name, mode);
3041 #endif /* !PERL_DISABLE_PMC */
3042 }
3043
3044 PP(pp_require)
3045 {
3046     dVAR; dSP;
3047     register PERL_CONTEXT *cx;
3048     SV *sv;
3049     const char *name;
3050     STRLEN len;
3051     const char *tryname = Nullch;
3052     SV *namesv = Nullsv;
3053     SV** svp;
3054     const I32 gimme = GIMME_V;
3055     PerlIO *tryrsfp = 0;
3056     int filter_has_file = 0;
3057     GV *filter_child_proc = 0;
3058     SV *filter_state = 0;
3059     SV *filter_sub = 0;
3060     SV *hook_sv = 0;
3061     SV *encoding;
3062     OP *op;
3063
3064     sv = POPs;
3065     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3066         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )       /* require v5.6.1 */
3067                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3068                         "v-string in use/require non-portable");
3069
3070         sv = new_version(sv);
3071         if (!sv_derived_from(PL_patchlevel, "version"))
3072             (void *)upg_version(PL_patchlevel);
3073         if ( vcmp(sv,PL_patchlevel) > 0 )
3074             DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3075                 vstringify(sv), vstringify(PL_patchlevel));
3076
3077             RETPUSHYES;
3078     }
3079     name = SvPV_const(sv, len);
3080     if (!(name && len > 0 && *name))
3081         DIE(aTHX_ "Null filename used");
3082     TAINT_PROPER("require");
3083     if (PL_op->op_type == OP_REQUIRE &&
3084        (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3085        if (*svp != &PL_sv_undef)
3086            RETPUSHYES;
3087        else
3088            DIE(aTHX_ "Compilation failed in require");
3089     }
3090
3091     /* prepare to compile file */
3092
3093     if (path_is_absolute(name)) {
3094         tryname = name;
3095         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3096     }
3097 #ifdef MACOS_TRADITIONAL
3098     if (!tryrsfp) {
3099         char newname[256];
3100
3101         MacPerl_CanonDir(name, newname, 1);
3102         if (path_is_absolute(newname)) {
3103             tryname = newname;
3104             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3105         }
3106     }
3107 #endif
3108     if (!tryrsfp) {
3109         AV *ar = GvAVn(PL_incgv);
3110         I32 i;
3111 #ifdef VMS
3112         char *unixname;
3113         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3114 #endif
3115         {
3116             namesv = NEWSV(806, 0);
3117             for (i = 0; i <= AvFILL(ar); i++) {
3118                 SV *dirsv = *av_fetch(ar, i, TRUE);
3119
3120                 if (SvROK(dirsv)) {
3121                     int count;
3122                     SV *loader = dirsv;
3123
3124                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3125                         && !sv_isobject(loader))
3126                     {
3127                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3128                     }
3129
3130                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3131                                    PTR2UV(SvRV(dirsv)), name);
3132                     tryname = SvPVX(namesv);
3133                     tryrsfp = 0;
3134
3135                     ENTER;
3136                     SAVETMPS;
3137                     EXTEND(SP, 2);
3138
3139                     PUSHMARK(SP);
3140                     PUSHs(dirsv);
3141                     PUSHs(sv);
3142                     PUTBACK;
3143                     if (sv_isobject(loader))
3144                         count = call_method("INC", G_ARRAY);
3145                     else
3146                         count = call_sv(loader, G_ARRAY);
3147                     SPAGAIN;
3148
3149                     if (count > 0) {
3150                         int i = 0;
3151                         SV *arg;
3152
3153                         SP -= count - 1;
3154                         arg = SP[i++];
3155
3156                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3157                             arg = SvRV(arg);
3158                         }
3159
3160                         if (SvTYPE(arg) == SVt_PVGV) {
3161                             IO *io = GvIO((GV *)arg);
3162
3163                             ++filter_has_file;
3164
3165                             if (io) {
3166                                 tryrsfp = IoIFP(io);
3167                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3168                                     /* reading from a child process doesn't
3169                                        nest -- when returning from reading
3170                                        the inner module, the outer one is
3171                                        unreadable (closed?)  I've tried to
3172                                        save the gv to manage the lifespan of
3173                                        the pipe, but this didn't help. XXX */
3174                                     filter_child_proc = (GV *)arg;
3175                                     (void)SvREFCNT_inc(filter_child_proc);
3176                                 }
3177                                 else {
3178                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3179                                         PerlIO_close(IoOFP(io));
3180                                     }
3181                                     IoIFP(io) = Nullfp;
3182                                     IoOFP(io) = Nullfp;
3183                                 }
3184                             }
3185
3186                             if (i < count) {
3187                                 arg = SP[i++];
3188                             }
3189                         }
3190
3191                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3192                             filter_sub = arg;
3193                             (void)SvREFCNT_inc(filter_sub);
3194
3195                             if (i < count) {
3196                                 filter_state = SP[i];
3197                                 (void)SvREFCNT_inc(filter_state);
3198                             }
3199
3200                             if (tryrsfp == 0) {
3201                                 tryrsfp = PerlIO_open("/dev/null",
3202                                                       PERL_SCRIPT_MODE);
3203                             }
3204                         }
3205                         SP--;
3206                     }
3207
3208                     PUTBACK;
3209                     FREETMPS;
3210                     LEAVE;
3211
3212                     if (tryrsfp) {
3213                         hook_sv = dirsv;
3214                         break;
3215                     }
3216
3217                     filter_has_file = 0;
3218                     if (filter_child_proc) {
3219                         SvREFCNT_dec(filter_child_proc);
3220                         filter_child_proc = 0;
3221                     }
3222                     if (filter_state) {
3223                         SvREFCNT_dec(filter_state);
3224                         filter_state = 0;
3225                     }
3226                     if (filter_sub) {
3227                         SvREFCNT_dec(filter_sub);
3228                         filter_sub = 0;
3229                     }
3230                 }
3231                 else {
3232                   if (!path_is_absolute(name)
3233 #ifdef MACOS_TRADITIONAL
3234                         /* We consider paths of the form :a:b ambiguous and interpret them first
3235                            as global then as local
3236                         */
3237                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3238 #endif
3239                   ) {
3240                     const char *dir = SvPVx_nolen_const(dirsv);
3241 #ifdef MACOS_TRADITIONAL
3242                     char buf1[256];
3243                     char buf2[256];
3244
3245                     MacPerl_CanonDir(name, buf2, 1);
3246                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3247 #else
3248 #  ifdef VMS
3249                     char *unixdir;
3250                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3251                         continue;
3252                     sv_setpv(namesv, unixdir);
3253                     sv_catpv(namesv, unixname);
3254 #  else
3255 #    ifdef SYMBIAN
3256                     if (PL_origfilename[0] &&
3257                         PL_origfilename[1] == ':' &&
3258                         !(dir[0] && dir[1] == ':'))
3259                         Perl_sv_setpvf(aTHX_ namesv,
3260                                        "%c:%s\\%s",
3261                                        PL_origfilename[0],
3262                                        dir, name);
3263                     else
3264                         Perl_sv_setpvf(aTHX_ namesv,
3265                                        "%s\\%s",
3266                                        dir, name);
3267 #    else
3268                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3269 #    endif
3270 #  endif
3271 #endif
3272                     TAINT_PROPER("require");
3273                     tryname = SvPVX(namesv);
3274                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3275                     if (tryrsfp) {
3276                         if (tryname[0] == '.' && tryname[1] == '/')
3277                             tryname += 2;
3278                         break;
3279                     }
3280                   }
3281                 }
3282             }
3283         }
3284     }
3285     SAVECOPFILE_FREE(&PL_compiling);
3286     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3287     SvREFCNT_dec(namesv);
3288     if (!tryrsfp) {
3289         if (PL_op->op_type == OP_REQUIRE) {
3290             const char *msgstr = name;
3291             if (namesv) {                       /* did we lookup @INC? */
3292                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3293                 SV *dirmsgsv = NEWSV(0, 0);
3294                 AV *ar = GvAVn(PL_incgv);
3295                 I32 i;
3296                 sv_catpvn(msg, " in @INC", 8);
3297                 if (instr(SvPVX_const(msg), ".h "))
3298                     sv_catpv(msg, " (change .h to .ph maybe?)");
3299                 if (instr(SvPVX_const(msg), ".ph "))
3300                     sv_catpv(msg, " (did you run h2ph?)");
3301                 sv_catpv(msg, " (@INC contains:");
3302                 for (i = 0; i <= AvFILL(ar); i++) {
3303                     const char *dir = SvPVx_nolen_const(*av_fetch(ar, i, TRUE));
3304                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3305                     sv_catsv(msg, dirmsgsv);
3306                 }
3307                 sv_catpvn(msg, ")", 1);
3308                 SvREFCNT_dec(dirmsgsv);
3309                 msgstr = SvPV_nolen(msg);
3310             }
3311             DIE(aTHX_ "Can't locate %s", msgstr);
3312         }
3313
3314         RETPUSHUNDEF;
3315     }
3316     else
3317         SETERRNO(0, SS_NORMAL);
3318
3319     /* Assume success here to prevent recursive requirement. */
3320     len = strlen(name);
3321     /* Check whether a hook in @INC has already filled %INC */
3322     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3323         (void)hv_store(GvHVn(PL_incgv), name, len,
3324                        (hook_sv ? SvREFCNT_inc(hook_sv)
3325                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3326                        0 );
3327     }
3328
3329     ENTER;
3330     SAVETMPS;
3331     lex_start(sv_2mortal(newSVpvn("",0)));
3332     SAVEGENERICSV(PL_rsfp_filters);
3333     PL_rsfp_filters = Nullav;
3334
3335     PL_rsfp = tryrsfp;
3336     SAVEHINTS();
3337     PL_hints = 0;
3338     SAVESPTR(PL_compiling.cop_warnings);
3339     if (PL_dowarn & G_WARN_ALL_ON)
3340         PL_compiling.cop_warnings = pWARN_ALL ;
3341     else if (PL_dowarn & G_WARN_ALL_OFF)
3342         PL_compiling.cop_warnings = pWARN_NONE ;
3343     else if (PL_taint_warn)
3344         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3345     else
3346         PL_compiling.cop_warnings = pWARN_STD ;
3347     SAVESPTR(PL_compiling.cop_io);
3348     PL_compiling.cop_io = Nullsv;
3349
3350     if (filter_sub || filter_child_proc) {
3351         SV *datasv = filter_add(run_user_filter, Nullsv);
3352         IoLINES(datasv) = filter_has_file;
3353         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3354         IoTOP_GV(datasv) = (GV *)filter_state;
3355         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3356     }
3357
3358     /* switch to eval mode */
3359     PUSHBLOCK(cx, CXt_EVAL, SP);
3360     PUSHEVAL(cx, name, Nullgv);
3361     cx->blk_eval.retop = PL_op->op_next;
3362
3363     SAVECOPLINE(&PL_compiling);
3364     CopLINE_set(&PL_compiling, 0);
3365
3366     PUTBACK;
3367
3368     /* Store and reset encoding. */
3369     encoding = PL_encoding;
3370     PL_encoding = Nullsv;
3371
3372     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3373
3374     /* Restore encoding. */
3375     PL_encoding = encoding;
3376
3377     return op;
3378 }
3379
3380 PP(pp_dofile)
3381 {
3382     return pp_require();
3383 }
3384
3385 PP(pp_entereval)
3386 {
3387     dVAR; dSP;
3388     register PERL_CONTEXT *cx;
3389     dPOPss;
3390     const I32 gimme = GIMME_V, was = PL_sub_generation;
3391     char tbuf[TYPE_DIGITS(long) + 12];
3392     char *tmpbuf = tbuf;
3393     char *safestr;
3394     STRLEN len;
3395     OP *ret;
3396     CV* runcv;
3397     U32 seq;
3398
3399     if (!SvPV_const(sv,len))
3400         RETPUSHUNDEF;
3401     TAINT_PROPER("eval");
3402
3403     ENTER;
3404     lex_start(sv);
3405     SAVETMPS;
3406
3407     /* switch to eval mode */
3408
3409     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3410         SV *sv = sv_newmortal();
3411         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3412                        (unsigned long)++PL_evalseq,
3413                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3414         tmpbuf = SvPVX(sv);
3415     }
3416     else
3417         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3418     SAVECOPFILE_FREE(&PL_compiling);
3419     CopFILE_set(&PL_compiling, tmpbuf+2);
3420     SAVECOPLINE(&PL_compiling);
3421     CopLINE_set(&PL_compiling, 1);
3422     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3423        deleting the eval's FILEGV from the stash before gv_check() runs
3424        (i.e. before run-time proper). To work around the coredump that
3425        ensues, we always turn GvMULTI_on for any globals that were
3426        introduced within evals. See force_ident(). GSAR 96-10-12 */
3427     safestr = savepv(tmpbuf);
3428     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3429     SAVEHINTS();
3430     PL_hints = PL_op->op_targ;
3431     SAVESPTR(PL_compiling.cop_warnings);
3432     if (specialWARN(PL_curcop->cop_warnings))
3433         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3434     else {
3435         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3436         SAVEFREESV(PL_compiling.cop_warnings);
3437     }
3438     SAVESPTR(PL_compiling.cop_io);
3439     if (specialCopIO(PL_curcop->cop_io))
3440         PL_compiling.cop_io = PL_curcop->cop_io;
3441     else {
3442         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3443         SAVEFREESV(PL_compiling.cop_io);
3444     }
3445     /* special case: an eval '' executed within the DB package gets lexically
3446      * placed in the first non-DB CV rather than the current CV - this
3447      * allows the debugger to execute code, find lexicals etc, in the
3448      * scope of the code being debugged. Passing &seq gets find_runcv
3449      * to do the dirty work for us */
3450     runcv = find_runcv(&seq);
3451
3452     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3453     PUSHEVAL(cx, 0, Nullgv);
3454     cx->blk_eval.retop = PL_op->op_next;
3455
3456     /* prepare to compile string */
3457
3458     if (PERLDB_LINE && PL_curstash != PL_debstash)
3459         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3460     PUTBACK;
3461     ret = doeval(gimme, NULL, runcv, seq);
3462     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3463         && ret != PL_op->op_next) {     /* Successive compilation. */
3464         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3465     }
3466     return DOCATCH(ret);
3467 }
3468
3469 PP(pp_leaveeval)
3470 {
3471     dVAR; dSP;
3472     register SV **mark;
3473     SV **newsp;
3474     PMOP *newpm;
3475     I32 gimme;
3476     register PERL_CONTEXT *cx;
3477     OP *retop;
3478     const U8 save_flags = PL_op -> op_flags;
3479     I32 optype;
3480
3481     POPBLOCK(cx,newpm);
3482     POPEVAL(cx);
3483     retop = cx->blk_eval.retop;
3484
3485     TAINT_NOT;
3486     if (gimme == G_VOID)
3487         MARK = newsp;
3488     else if (gimme == G_SCALAR) {
3489         MARK = newsp + 1;
3490         if (MARK <= SP) {
3491             if (SvFLAGS(TOPs) & SVs_TEMP)
3492                 *MARK = TOPs;
3493             else
3494                 *MARK = sv_mortalcopy(TOPs);
3495         }
3496         else {
3497             MEXTEND(mark,0);
3498             *MARK = &PL_sv_undef;
3499         }
3500         SP = MARK;
3501     }
3502     else {
3503         /* in case LEAVE wipes old return values */
3504         for (mark = newsp + 1; mark <= SP; mark++) {
3505             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3506                 *mark = sv_mortalcopy(*mark);
3507                 TAINT_NOT;      /* Each item is independent */
3508             }
3509         }
3510     }
3511     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3512
3513 #ifdef DEBUGGING
3514     assert(CvDEPTH(PL_compcv) == 1);
3515 #endif
3516     CvDEPTH(PL_compcv) = 0;
3517     lex_end();
3518
3519     if (optype == OP_REQUIRE &&
3520         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3521     {
3522         /* Unassume the success we assumed earlier. */
3523         SV *nsv = cx->blk_eval.old_namesv;
3524         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3525         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3526         /* die_where() did LEAVE, or we won't be here */
3527     }
3528     else {
3529         LEAVE;
3530         if (!(save_flags & OPf_SPECIAL))
3531             sv_setpvn(ERRSV,"",0);
3532     }
3533
3534     RETURNOP(retop);
3535 }
3536
3537 PP(pp_entertry)
3538 {
3539     dVAR; dSP;
3540     register PERL_CONTEXT *cx;
3541     const I32 gimme = GIMME_V;
3542
3543     ENTER;
3544     SAVETMPS;
3545
3546     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3547     PUSHEVAL(cx, 0, 0);
3548     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3549
3550     PL_in_eval = EVAL_INEVAL;
3551     sv_setpvn(ERRSV,"",0);
3552     PUTBACK;
3553     return DOCATCH(PL_op->op_next);
3554 }
3555
3556 PP(pp_leavetry)
3557 {
3558     dVAR; dSP;
3559     register SV **mark;
3560     SV **newsp;
3561     PMOP *newpm;
3562     I32 gimme;
3563     register PERL_CONTEXT *cx;
3564     I32 optype;
3565
3566     POPBLOCK(cx,newpm);
3567     POPEVAL(cx);
3568
3569     TAINT_NOT;
3570     if (gimme == G_VOID)
3571         SP = newsp;
3572     else if (gimme == G_SCALAR) {
3573         MARK = newsp + 1;
3574         if (MARK <= SP) {
3575             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3576                 *MARK = TOPs;
3577             else
3578                 *MARK = sv_mortalcopy(TOPs);
3579         }
3580         else {
3581             MEXTEND(mark,0);
3582             *MARK = &PL_sv_undef;
3583         }
3584         SP = MARK;
3585     }
3586     else {
3587         /* in case LEAVE wipes old return values */
3588         for (mark = newsp + 1; mark <= SP; mark++) {
3589             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3590                 *mark = sv_mortalcopy(*mark);
3591                 TAINT_NOT;      /* Each item is independent */
3592             }
3593         }
3594     }
3595     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3596
3597     LEAVE;
3598     sv_setpvn(ERRSV,"",0);
3599     RETURN;
3600 }
3601
3602 STATIC OP *
3603 S_doparseform(pTHX_ SV *sv)
3604 {
3605     STRLEN len;
3606     register char *s = SvPV_force(sv, len);
3607     register char *send = s + len;
3608     register char *base = Nullch;
3609     register I32 skipspaces = 0;
3610     bool noblank   = FALSE;
3611     bool repeat    = FALSE;
3612     bool postspace = FALSE;
3613     U32 *fops;
3614     register U32 *fpc;
3615     U32 *linepc = 0;
3616     register I32 arg;
3617     bool ischop;
3618     bool unchopnum = FALSE;
3619     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3620
3621     if (len == 0)
3622         Perl_croak(aTHX_ "Null picture in formline");
3623
3624     /* estimate the buffer size needed */
3625     for (base = s; s <= send; s++) {
3626         if (*s == '\n' || *s == '@' || *s == '^')
3627             maxops += 10;
3628     }
3629     s = base;
3630     base = Nullch;
3631
3632     New(804, fops, maxops, U32);
3633     fpc = fops;
3634
3635     if (s < send) {
3636         linepc = fpc;
3637         *fpc++ = FF_LINEMARK;
3638         noblank = repeat = FALSE;
3639         base = s;
3640     }
3641
3642     while (s <= send) {
3643         switch (*s++) {
3644         default:
3645             skipspaces = 0;
3646             continue;
3647
3648         case '~':
3649             if (*s == '~') {
3650                 repeat = TRUE;
3651                 *s = ' ';
3652             }
3653             noblank = TRUE;
3654             s[-1] = ' ';
3655             /* FALL THROUGH */
3656         case ' ': case '\t':
3657             skipspaces++;
3658             continue;
3659         case 0:
3660             if (s < send) {
3661                 skipspaces = 0;
3662                 continue;
3663             } /* else FALL THROUGH */
3664         case '\n':
3665             arg = s - base;
3666             skipspaces++;
3667             arg -= skipspaces;
3668             if (arg) {
3669                 if (postspace)
3670                     *fpc++ = FF_SPACE;
3671                 *fpc++ = FF_LITERAL;
3672                 *fpc++ = (U16)arg;
3673             }
3674             postspace = FALSE;
3675             if (s <= send)
3676                 skipspaces--;
3677             if (skipspaces) {
3678                 *fpc++ = FF_SKIP;
3679                 *fpc++ = (U16)skipspaces;
3680             }
3681             skipspaces = 0;
3682             if (s <= send)
3683                 *fpc++ = FF_NEWLINE;
3684             if (noblank) {
3685                 *fpc++ = FF_BLANK;
3686                 if (repeat)
3687                     arg = fpc - linepc + 1;
3688                 else
3689                     arg = 0;
3690                 *fpc++ = (U16)arg;
3691             }
3692             if (s < send) {
3693                 linepc = fpc;
3694                 *fpc++ = FF_LINEMARK;
3695                 noblank = repeat = FALSE;
3696                 base = s;
3697             }
3698             else
3699                 s++;
3700             continue;
3701
3702         case '@':
3703         case '^':
3704             ischop = s[-1] == '^';
3705
3706             if (postspace) {
3707                 *fpc++ = FF_SPACE;
3708                 postspace = FALSE;
3709             }
3710             arg = (s - base) - 1;
3711             if (arg) {
3712                 *fpc++ = FF_LITERAL;
3713                 *fpc++ = (U16)arg;
3714             }
3715
3716             base = s - 1;
3717             *fpc++ = FF_FETCH;
3718             if (*s == '*') {
3719                 s++;
3720                 *fpc++ = 2;  /* skip the @* or ^* */
3721                 if (ischop) {
3722                     *fpc++ = FF_LINESNGL;
3723                     *fpc++ = FF_CHOP;
3724                 } else
3725                     *fpc++ = FF_LINEGLOB;
3726             }
3727             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3728                 arg = ischop ? 512 : 0;
3729                 base = s - 1;
3730                 while (*s == '#')
3731                     s++;
3732                 if (*s == '.') {
3733                     const char * const f = ++s;
3734                     while (*s == '#')
3735                         s++;
3736                     arg |= 256 + (s - f);
3737                 }
3738                 *fpc++ = s - base;              /* fieldsize for FETCH */
3739                 *fpc++ = FF_DECIMAL;
3740                 *fpc++ = (U16)arg;
3741                 unchopnum |= ! ischop;
3742             }
3743             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3744                 arg = ischop ? 512 : 0;
3745                 base = s - 1;
3746                 s++;                                /* skip the '0' first */
3747                 while (*s == '#')
3748                     s++;
3749                 if (*s == '.') {
3750                     const char * const f = ++s;
3751                     while (*s == '#')
3752                         s++;
3753                     arg |= 256 + (s - f);
3754                 }
3755                 *fpc++ = s - base;                /* fieldsize for FETCH */
3756                 *fpc++ = FF_0DECIMAL;
3757                 *fpc++ = (U16)arg;
3758                 unchopnum |= ! ischop;
3759             }
3760             else {
3761                 I32 prespace = 0;
3762                 bool ismore = FALSE;
3763
3764                 if (*s == '>') {
3765                     while (*++s == '>') ;
3766                     prespace = FF_SPACE;
3767                 }
3768                 else if (*s == '|') {
3769                     while (*++s == '|') ;
3770                     prespace = FF_HALFSPACE;
3771                     postspace = TRUE;
3772                 }
3773                 else {
3774                     if (*s == '<')
3775                         while (*++s == '<') ;
3776                     postspace = TRUE;
3777                 }
3778                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3779                     s += 3;
3780                     ismore = TRUE;
3781                 }
3782                 *fpc++ = s - base;              /* fieldsize for FETCH */
3783
3784                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3785
3786                 if (prespace)
3787                     *fpc++ = (U16)prespace;
3788                 *fpc++ = FF_ITEM;
3789                 if (ismore)
3790                     *fpc++ = FF_MORE;
3791                 if (ischop)
3792                     *fpc++ = FF_CHOP;
3793             }
3794             base = s;
3795             skipspaces = 0;
3796             continue;
3797         }
3798     }
3799     *fpc++ = FF_END;
3800
3801     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3802     arg = fpc - fops;
3803     { /* need to jump to the next word */
3804         int z;
3805         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3806         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3807         s = SvPVX(sv) + SvCUR(sv) + z;
3808     }
3809     Copy(fops, s, arg, U32);
3810     Safefree(fops);
3811     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3812     SvCOMPILED_on(sv);
3813
3814     if (unchopnum && repeat)
3815         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3816     return 0;
3817 }
3818
3819
3820 STATIC bool
3821 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3822 {
3823     /* Can value be printed in fldsize chars, using %*.*f ? */
3824     NV pwr = 1;
3825     NV eps = 0.5;
3826     bool res = FALSE;
3827     int intsize = fldsize - (value < 0 ? 1 : 0);
3828
3829     if (frcsize & 256)
3830         intsize--;
3831     frcsize &= 255;
3832     intsize -= frcsize;
3833
3834     while (intsize--) pwr *= 10.0;
3835     while (frcsize--) eps /= 10.0;
3836
3837     if( value >= 0 ){
3838         if (value + eps >= pwr)
3839             res = TRUE;
3840     } else {
3841         if (value - eps <= -pwr)
3842             res = TRUE;
3843     }
3844     return res;
3845 }
3846
3847 static I32
3848 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3849 {
3850     dVAR;
3851     SV *datasv = FILTER_DATA(idx);
3852     const int filter_has_file = IoLINES(datasv);
3853     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3854     SV *filter_state = (SV *)IoTOP_GV(datasv);
3855     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3856     int len = 0;
3857
3858     /* I was having segfault trouble under Linux 2.2.5 after a
3859        parse error occured.  (Had to hack around it with a test
3860        for PL_error_count == 0.)  Solaris doesn't segfault --
3861        not sure where the trouble is yet.  XXX */
3862
3863     if (filter_has_file) {
3864         len = FILTER_READ(idx+1, buf_sv, maxlen);
3865     }
3866
3867     if (filter_sub && len >= 0) {
3868         dSP;
3869         int count;
3870
3871         ENTER;
3872         SAVE_DEFSV;
3873         SAVETMPS;
3874         EXTEND(SP, 2);
3875
3876         DEFSV = buf_sv;
3877         PUSHMARK(SP);
3878         PUSHs(sv_2mortal(newSViv(maxlen)));
3879         if (filter_state) {
3880             PUSHs(filter_state);
3881         }
3882         PUTBACK;
3883         count = call_sv(filter_sub, G_SCALAR);
3884         SPAGAIN;
3885
3886         if (count > 0) {
3887             SV *out = POPs;
3888             if (SvOK(out)) {
3889                 len = SvIV(out);
3890             }
3891         }
3892
3893         PUTBACK;
3894         FREETMPS;
3895         LEAVE;
3896     }
3897
3898     if (len <= 0) {
3899         IoLINES(datasv) = 0;
3900         if (filter_child_proc) {
3901             SvREFCNT_dec(filter_child_proc);
3902             IoFMT_GV(datasv) = Nullgv;
3903         }
3904         if (filter_state) {
3905             SvREFCNT_dec(filter_state);
3906             IoTOP_GV(datasv) = Nullgv;
3907         }
3908         if (filter_sub) {
3909             SvREFCNT_dec(filter_sub);
3910             IoBOTTOM_GV(datasv) = Nullgv;
3911         }
3912         filter_del(run_user_filter);
3913     }
3914
3915     return len;
3916 }
3917
3918 /* perhaps someone can come up with a better name for
3919    this?  it is not really "absolute", per se ... */
3920 static bool
3921 S_path_is_absolute(pTHX_ const char *name)
3922 {
3923     if (PERL_FILE_IS_ABSOLUTE(name)
3924 #ifdef MACOS_TRADITIONAL
3925         || (*name == ':'))
3926 #else
3927         || (*name == '.' && (name[1] == '/' ||
3928                              (name[1] == '.' && name[2] == '/'))))
3929 #endif
3930     {
3931         return TRUE;
3932     }
3933     else
3934         return FALSE;
3935 }
3936
3937 /*
3938  * Local variables:
3939  * c-indentation-style: bsd
3940  * c-basic-offset: 4
3941  * indent-tabs-mode: t
3942  * End:
3943  *
3944  * ex: set ts=8 sts=4 sw=4 noet:
3945  */