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