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