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