pp_ctl.c

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