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