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