pp_ctl.c

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