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