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