pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (c) 1991-2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * Now far ahead the Road has gone,
  12  * And I must follow, if I can,
  13  * Pursuing it with eager feet,
  14  * Until it joins some larger way
  15  * Where many paths and errands meet.
  16  * And whither then?  I cannot say.
  17  */
  18
  19 #include "EXTERN.h"
  20 #define PERL_IN_PP_CTL_C
  21 #include "perl.h"
  22
  23 #ifndef WORD_ALIGN
  24 #define WORD_ALIGN sizeof(U16)
  25 #endif
  26
  27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  28
  29 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
  30
  31 PP(pp_wantarray)
  32 {
  33     dSP;
  34     I32 cxix;
  35     EXTEND(SP, 1);
  36
  37     cxix = dopoptosub(cxstack_ix);
  38     if (cxix < 0)
  39         RETPUSHUNDEF;
  40
  41     switch (cxstack[cxix].blk_gimme) {
  42     case G_ARRAY:
  43         RETPUSHYES;
  44     case G_SCALAR:
  45         RETPUSHNO;
  46     default:
  47         RETPUSHUNDEF;
  48     }
  49 }
  50
  51 PP(pp_regcmaybe)
  52 {
  53     return NORMAL;
  54 }
  55
  56 PP(pp_regcreset)
  57 {
  58     /* XXXX Should store the old value to allow for tie/overload - and
  59        restore in regcomp, where marked with XXXX. */
  60     PL_reginterp_cnt = 0;
  61     return NORMAL;
  62 }
  63
  64 PP(pp_regcomp)
  65 {
  66     dSP;
  67     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  68     register char *t;
  69     SV *tmpstr;
  70     STRLEN len;
  71     MAGIC *mg = Null(MAGIC*);
  72
  73     tmpstr = POPs;
  74
  75     /* prevent recompiling under /o and ithreads. */
  76 #if defined(USE_ITHREADS) || defined(USE_5005THREADS)
  77     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
  78          RETURN;
  79 #endif
  80
  81     if (SvROK(tmpstr)) {
  82         SV *sv = SvRV(tmpstr);
  83         if(SvMAGICAL(sv))
  84             mg = mg_find(sv, PERL_MAGIC_qr);
  85     }
  86     if (mg) {
  87         regexp *re = (regexp *)mg->mg_obj;
  88         ReREFCNT_dec(PM_GETRE(pm));
  89         PM_SETRE(pm, ReREFCNT_inc(re));
  90     }
  91     else {
  92         t = SvPV(tmpstr, len);
  93
  94         /* Check against the last compiled regexp. */
  95         if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
  96             PM_GETRE(pm)->prelen != 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(OutCopFILE(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     if (path_is_absolute(name)) {
2931         tryname = name;
2932         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2933     }
2934     if (!tryrsfp) {
2935         AV *ar = GvAVn(PL_incgv);
2936         I32 i;
2937 #ifdef VMS
2938         char *unixname;
2939         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2940 #endif
2941         {
2942             namesv = NEWSV(806, 0);
2943             for (i = 0; i <= AvFILL(ar); i++) {
2944                 SV *dirsv = *av_fetch(ar, i, TRUE);
2945
2946                 if (SvROK(dirsv)) {
2947                     int count;
2948                     SV *loader = dirsv;
2949
2950                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
2951                         && !sv_isobject(loader))
2952                     {
2953                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2954                     }
2955
2956                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2957                                    PTR2UV(SvRV(dirsv)), name);
2958                     tryname = SvPVX(namesv);
2959                     tryrsfp = 0;
2960
2961                     ENTER;
2962                     SAVETMPS;
2963                     EXTEND(SP, 2);
2964
2965                     PUSHMARK(SP);
2966                     PUSHs(dirsv);
2967                     PUSHs(sv);
2968                     PUTBACK;
2969                     if (sv_isobject(loader))
2970                         count = call_method("INC", G_ARRAY);
2971                     else
2972                         count = call_sv(loader, G_ARRAY);
2973                     SPAGAIN;
2974
2975                     if (count > 0) {
2976                         int i = 0;
2977                         SV *arg;
2978
2979                         SP -= count - 1;
2980                         arg = SP[i++];
2981
2982                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2983                             arg = SvRV(arg);
2984                         }
2985
2986                         if (SvTYPE(arg) == SVt_PVGV) {
2987                             IO *io = GvIO((GV *)arg);
2988
2989                             ++filter_has_file;
2990
2991                             if (io) {
2992                                 tryrsfp = IoIFP(io);
2993                                 if (IoTYPE(io) == IoTYPE_PIPE) {
2994                                     /* reading from a child process doesn't
2995                                        nest -- when returning from reading
2996                                        the inner module, the outer one is
2997                                        unreadable (closed?)  I've tried to
2998                                        save the gv to manage the lifespan of
2999                                        the pipe, but this didn't help. XXX */
3000                                     filter_child_proc = (GV *)arg;
3001                                     (void)SvREFCNT_inc(filter_child_proc);
3002                                 }
3003                                 else {
3004                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3005                                         PerlIO_close(IoOFP(io));
3006                                     }
3007                                     IoIFP(io) = Nullfp;
3008                                     IoOFP(io) = Nullfp;
3009                                 }
3010                             }
3011
3012                             if (i < count) {
3013                                 arg = SP[i++];
3014                             }
3015                         }
3016
3017                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3018                             filter_sub = arg;
3019                             (void)SvREFCNT_inc(filter_sub);
3020
3021                             if (i < count) {
3022                                 filter_state = SP[i];
3023                                 (void)SvREFCNT_inc(filter_state);
3024                             }
3025
3026                             if (tryrsfp == 0) {
3027                                 tryrsfp = PerlIO_open("/dev/null",
3028                                                       PERL_SCRIPT_MODE);
3029                             }
3030                         }
3031                     }
3032
3033                     PUTBACK;
3034                     FREETMPS;
3035                     LEAVE;
3036
3037                     if (tryrsfp) {
3038                         hook_sv = dirsv;
3039                         break;
3040                     }
3041
3042                     filter_has_file = 0;
3043                     if (filter_child_proc) {
3044                         SvREFCNT_dec(filter_child_proc);
3045                         filter_child_proc = 0;
3046                     }
3047                     if (filter_state) {
3048                         SvREFCNT_dec(filter_state);
3049                         filter_state = 0;
3050                     }
3051                     if (filter_sub) {
3052                         SvREFCNT_dec(filter_sub);
3053                         filter_sub = 0;
3054                     }
3055                 }
3056                 else {
3057                   if (!path_is_absolute(name)
3058 #ifdef MACOS_TRADITIONAL
3059                         /* We consider paths of the form :a:b ambiguous and interpret them first
3060                            as global then as local
3061                         */
3062                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3063 #endif
3064                   ) {
3065                     char *dir = SvPVx(dirsv, n_a);
3066 #ifdef MACOS_TRADITIONAL
3067                     char buf[256];
3068                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3069 #else
3070 #ifdef VMS
3071                     char *unixdir;
3072                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3073                         continue;
3074                     sv_setpv(namesv, unixdir);
3075                     sv_catpv(namesv, unixname);
3076 #else
3077                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3078 #endif
3079 #endif
3080                     TAINT_PROPER("require");
3081                     tryname = SvPVX(namesv);
3082 #ifdef MACOS_TRADITIONAL
3083                     {
3084                         /* Convert slashes in the name part, but not the directory part, to colons */
3085                         char * colon;
3086                         for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3087                             *colon++ = ':';
3088                     }
3089 #endif
3090                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3091                     if (tryrsfp) {
3092                         if (tryname[0] == '.' && tryname[1] == '/')
3093                             tryname += 2;
3094                         break;
3095                     }
3096                   }
3097                 }
3098             }
3099         }
3100     }
3101     SAVECOPFILE_FREE(&PL_compiling);
3102     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3103     SvREFCNT_dec(namesv);
3104     if (!tryrsfp) {
3105         if (PL_op->op_type == OP_REQUIRE) {
3106             char *msgstr = name;
3107             if (namesv) {                       /* did we lookup @INC? */
3108                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3109                 SV *dirmsgsv = NEWSV(0, 0);
3110                 AV *ar = GvAVn(PL_incgv);
3111                 I32 i;
3112                 sv_catpvn(msg, " in @INC", 8);
3113                 if (instr(SvPVX(msg), ".h "))
3114                     sv_catpv(msg, " (change .h to .ph maybe?)");
3115                 if (instr(SvPVX(msg), ".ph "))
3116                     sv_catpv(msg, " (did you run h2ph?)");
3117                 sv_catpv(msg, " (@INC contains:");
3118                 for (i = 0; i <= AvFILL(ar); i++) {
3119                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3120                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3121                     sv_catsv(msg, dirmsgsv);
3122                 }
3123                 sv_catpvn(msg, ")", 1);
3124                 SvREFCNT_dec(dirmsgsv);
3125                 msgstr = SvPV_nolen(msg);
3126             }
3127             DIE(aTHX_ "Can't locate %s", msgstr);
3128         }
3129
3130         RETPUSHUNDEF;
3131     }
3132     else
3133         SETERRNO(0, SS$_NORMAL);
3134
3135     /* Assume success here to prevent recursive requirement. */
3136     len = strlen(name);
3137     /* Check whether a hook in @INC has already filled %INC */
3138     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3139         (void)hv_store(GvHVn(PL_incgv), name, len,
3140                        (hook_sv ? SvREFCNT_inc(hook_sv)
3141                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3142                        0 );
3143     }
3144
3145     ENTER;
3146     SAVETMPS;
3147     lex_start(sv_2mortal(newSVpvn("",0)));
3148     SAVEGENERICSV(PL_rsfp_filters);
3149     PL_rsfp_filters = Nullav;
3150
3151     PL_rsfp = tryrsfp;
3152     SAVEHINTS();
3153     PL_hints = 0;
3154     SAVESPTR(PL_compiling.cop_warnings);
3155     if (PL_dowarn & G_WARN_ALL_ON)
3156         PL_compiling.cop_warnings = pWARN_ALL ;
3157     else if (PL_dowarn & G_WARN_ALL_OFF)
3158         PL_compiling.cop_warnings = pWARN_NONE ;
3159     else if (PL_taint_warn)
3160         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3161     else
3162         PL_compiling.cop_warnings = pWARN_STD ;
3163     SAVESPTR(PL_compiling.cop_io);
3164     PL_compiling.cop_io = Nullsv;
3165
3166     if (filter_sub || filter_child_proc) {
3167         SV *datasv = filter_add(run_user_filter, Nullsv);
3168         IoLINES(datasv) = filter_has_file;
3169         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3170         IoTOP_GV(datasv) = (GV *)filter_state;
3171         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3172     }
3173
3174     /* switch to eval mode */
3175     push_return(PL_op->op_next);
3176     PUSHBLOCK(cx, CXt_EVAL, SP);
3177     PUSHEVAL(cx, name, Nullgv);
3178
3179     SAVECOPLINE(&PL_compiling);
3180     CopLINE_set(&PL_compiling, 0);
3181
3182     PUTBACK;
3183 #ifdef USE_5005THREADS
3184     MUTEX_LOCK(&PL_eval_mutex);
3185     if (PL_eval_owner && PL_eval_owner != thr)
3186         while (PL_eval_owner)
3187             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3188     PL_eval_owner = thr;
3189     MUTEX_UNLOCK(&PL_eval_mutex);
3190 #endif /* USE_5005THREADS */
3191
3192     /* Store and reset encoding. */
3193     encoding = PL_encoding;
3194     PL_encoding = Nullsv;
3195
3196     op = DOCATCH(doeval(gimme, NULL));
3197
3198     /* Restore encoding. */
3199     PL_encoding = encoding;
3200
3201     return op;
3202 }
3203
3204 PP(pp_dofile)
3205 {
3206     return pp_require();
3207 }
3208
3209 PP(pp_entereval)
3210 {
3211     dSP;
3212     register PERL_CONTEXT *cx;
3213     dPOPss;
3214     I32 gimme = GIMME_V, was = PL_sub_generation;
3215     char tbuf[TYPE_DIGITS(long) + 12];
3216     char *tmpbuf = tbuf;
3217     char *safestr;
3218     STRLEN len;
3219     OP *ret;
3220
3221     if (!SvPV(sv,len) || !len)
3222         RETPUSHUNDEF;
3223     TAINT_PROPER("eval");
3224
3225     ENTER;
3226     lex_start(sv);
3227     SAVETMPS;
3228
3229     /* switch to eval mode */
3230
3231     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3232         SV *sv = sv_newmortal();
3233         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3234                        (unsigned long)++PL_evalseq,
3235                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3236         tmpbuf = SvPVX(sv);
3237     }
3238     else
3239         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3240     SAVECOPFILE_FREE(&PL_compiling);
3241     CopFILE_set(&PL_compiling, tmpbuf+2);
3242     SAVECOPLINE(&PL_compiling);
3243     CopLINE_set(&PL_compiling, 1);
3244     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3245        deleting the eval's FILEGV from the stash before gv_check() runs
3246        (i.e. before run-time proper). To work around the coredump that
3247        ensues, we always turn GvMULTI_on for any globals that were
3248        introduced within evals. See force_ident(). GSAR 96-10-12 */
3249     safestr = savepv(tmpbuf);
3250     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3251     SAVEHINTS();
3252     PL_hints = PL_op->op_targ;
3253     SAVESPTR(PL_compiling.cop_warnings);
3254     if (specialWARN(PL_curcop->cop_warnings))
3255         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3256     else {
3257         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3258         SAVEFREESV(PL_compiling.cop_warnings);
3259     }
3260     SAVESPTR(PL_compiling.cop_io);
3261     if (specialCopIO(PL_curcop->cop_io))
3262         PL_compiling.cop_io = PL_curcop->cop_io;
3263     else {
3264         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3265         SAVEFREESV(PL_compiling.cop_io);
3266     }
3267
3268     push_return(PL_op->op_next);
3269     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3270     PUSHEVAL(cx, 0, Nullgv);
3271
3272     /* prepare to compile string */
3273
3274     if (PERLDB_LINE && PL_curstash != PL_debstash)
3275         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3276     PUTBACK;
3277 #ifdef USE_5005THREADS
3278     MUTEX_LOCK(&PL_eval_mutex);
3279     if (PL_eval_owner && PL_eval_owner != thr)
3280         while (PL_eval_owner)
3281             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3282     PL_eval_owner = thr;
3283     MUTEX_UNLOCK(&PL_eval_mutex);
3284 #endif /* USE_5005THREADS */
3285     ret = doeval(gimme, NULL);
3286     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3287         && ret != PL_op->op_next) {     /* Successive compilation. */
3288         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3289     }
3290     return DOCATCH(ret);
3291 }
3292
3293 PP(pp_leaveeval)
3294 {
3295     dSP;
3296     register SV **mark;
3297     SV **newsp;
3298     PMOP *newpm;
3299     I32 gimme;
3300     register PERL_CONTEXT *cx;
3301     OP *retop;
3302     U8 save_flags = PL_op -> op_flags;
3303     I32 optype;
3304
3305     POPBLOCK(cx,newpm);
3306     POPEVAL(cx);
3307     retop = pop_return();
3308
3309     TAINT_NOT;
3310     if (gimme == G_VOID)
3311         MARK = newsp;
3312     else if (gimme == G_SCALAR) {
3313         MARK = newsp + 1;
3314         if (MARK <= SP) {
3315             if (SvFLAGS(TOPs) & SVs_TEMP)
3316                 *MARK = TOPs;
3317             else
3318                 *MARK = sv_mortalcopy(TOPs);
3319         }
3320         else {
3321             MEXTEND(mark,0);
3322             *MARK = &PL_sv_undef;
3323         }
3324         SP = MARK;
3325     }
3326     else {
3327         /* in case LEAVE wipes old return values */
3328         for (mark = newsp + 1; mark <= SP; mark++) {
3329             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3330                 *mark = sv_mortalcopy(*mark);
3331                 TAINT_NOT;      /* Each item is independent */
3332             }
3333         }
3334     }
3335     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3336
3337 #ifdef DEBUGGING
3338     assert(CvDEPTH(PL_compcv) == 1);
3339 #endif
3340     CvDEPTH(PL_compcv) = 0;
3341     lex_end();
3342
3343     if (optype == OP_REQUIRE &&
3344         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3345     {
3346         /* Unassume the success we assumed earlier. */
3347         SV *nsv = cx->blk_eval.old_namesv;
3348         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3349         retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3350         /* die_where() did LEAVE, or we won't be here */
3351     }
3352     else {
3353         LEAVE;
3354         if (!(save_flags & OPf_SPECIAL))
3355             sv_setpv(ERRSV,"");
3356     }
3357
3358     RETURNOP(retop);
3359 }
3360
3361 PP(pp_entertry)
3362 {
3363     dSP;
3364     register PERL_CONTEXT *cx;
3365     I32 gimme = GIMME_V;
3366
3367     ENTER;
3368     SAVETMPS;
3369
3370     push_return(cLOGOP->op_other->op_next);
3371     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3372     PUSHEVAL(cx, 0, 0);
3373
3374     PL_in_eval = EVAL_INEVAL;
3375     sv_setpv(ERRSV,"");
3376     PUTBACK;
3377     return DOCATCH(PL_op->op_next);
3378 }
3379
3380 PP(pp_leavetry)
3381 {
3382     dSP;
3383     register SV **mark;
3384     SV **newsp;
3385     PMOP *newpm;
3386     I32 gimme;
3387     register PERL_CONTEXT *cx;
3388     I32 optype;
3389
3390     POPBLOCK(cx,newpm);
3391     POPEVAL(cx);
3392     pop_return();
3393
3394     TAINT_NOT;
3395     if (gimme == G_VOID)
3396         SP = newsp;
3397     else if (gimme == G_SCALAR) {
3398         MARK = newsp + 1;
3399         if (MARK <= SP) {
3400             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3401                 *MARK = TOPs;
3402             else
3403                 *MARK = sv_mortalcopy(TOPs);
3404         }
3405         else {
3406             MEXTEND(mark,0);
3407             *MARK = &PL_sv_undef;
3408         }
3409         SP = MARK;
3410     }
3411     else {
3412         /* in case LEAVE wipes old return values */
3413         for (mark = newsp + 1; mark <= SP; mark++) {
3414             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3415                 *mark = sv_mortalcopy(*mark);
3416                 TAINT_NOT;      /* Each item is independent */
3417             }
3418         }
3419     }
3420     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3421
3422     LEAVE;
3423     sv_setpv(ERRSV,"");
3424     RETURN;
3425 }
3426
3427 STATIC void
3428 S_doparseform(pTHX_ SV *sv)
3429 {
3430     STRLEN len;
3431     register char *s = SvPV_force(sv, len);
3432     register char *send = s + len;
3433     register char *base = Nullch;
3434     register I32 skipspaces = 0;
3435     bool noblank   = FALSE;
3436     bool repeat    = FALSE;
3437     bool postspace = FALSE;
3438     U16 *fops;
3439     register U16 *fpc;
3440     U16 *linepc = 0;
3441     register I32 arg;
3442     bool ischop;
3443
3444     if (len == 0)
3445         Perl_croak(aTHX_ "Null picture in formline");
3446
3447     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3448     fpc = fops;
3449
3450     if (s < send) {
3451         linepc = fpc;
3452         *fpc++ = FF_LINEMARK;
3453         noblank = repeat = FALSE;
3454         base = s;
3455     }
3456
3457     while (s <= send) {
3458         switch (*s++) {
3459         default:
3460             skipspaces = 0;
3461             continue;
3462
3463         case '~':
3464             if (*s == '~') {
3465                 repeat = TRUE;
3466                 *s = ' ';
3467             }
3468             noblank = TRUE;
3469             s[-1] = ' ';
3470             /* FALL THROUGH */
3471         case ' ': case '\t':
3472             skipspaces++;
3473             continue;
3474
3475         case '\n': case 0:
3476             arg = s - base;
3477             skipspaces++;
3478             arg -= skipspaces;
3479             if (arg) {
3480                 if (postspace)
3481                     *fpc++ = FF_SPACE;
3482                 *fpc++ = FF_LITERAL;
3483                 *fpc++ = arg;
3484             }
3485             postspace = FALSE;
3486             if (s <= send)
3487                 skipspaces--;
3488             if (skipspaces) {
3489                 *fpc++ = FF_SKIP;
3490                 *fpc++ = skipspaces;
3491             }
3492             skipspaces = 0;
3493             if (s <= send)
3494                 *fpc++ = FF_NEWLINE;
3495             if (noblank) {
3496                 *fpc++ = FF_BLANK;
3497                 if (repeat)
3498                     arg = fpc - linepc + 1;
3499                 else
3500                     arg = 0;
3501                 *fpc++ = arg;
3502             }
3503             if (s < send) {
3504                 linepc = fpc;
3505                 *fpc++ = FF_LINEMARK;
3506                 noblank = repeat = FALSE;
3507                 base = s;
3508             }
3509             else
3510                 s++;
3511             continue;
3512
3513         case '@':
3514         case '^':
3515             ischop = s[-1] == '^';
3516
3517             if (postspace) {
3518                 *fpc++ = FF_SPACE;
3519                 postspace = FALSE;
3520             }
3521             arg = (s - base) - 1;
3522             if (arg) {
3523                 *fpc++ = FF_LITERAL;
3524                 *fpc++ = arg;
3525             }
3526
3527             base = s - 1;
3528             *fpc++ = FF_FETCH;
3529             if (*s == '*') {
3530                 s++;
3531                 *fpc++ = 0;
3532                 *fpc++ = FF_LINEGLOB;
3533             }
3534             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3535                 arg = ischop ? 512 : 0;
3536                 base = s - 1;
3537                 while (*s == '#')
3538                     s++;
3539                 if (*s == '.') {
3540                     char *f;
3541                     s++;
3542                     f = s;
3543                     while (*s == '#')
3544                         s++;
3545                     arg |= 256 + (s - f);
3546                 }
3547                 *fpc++ = s - base;              /* fieldsize for FETCH */
3548                 *fpc++ = FF_DECIMAL;
3549                 *fpc++ = arg;
3550             }
3551             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3552                 arg = ischop ? 512 : 0;
3553                 base = s - 1;
3554                 s++;                                /* skip the '0' first */
3555                 while (*s == '#')
3556                     s++;
3557                 if (*s == '.') {
3558                     char *f;
3559                     s++;
3560                     f = s;
3561                     while (*s == '#')
3562                         s++;
3563                     arg |= 256 + (s - f);
3564                 }
3565                 *fpc++ = s - base;                /* fieldsize for FETCH */
3566                 *fpc++ = FF_0DECIMAL;
3567                 *fpc++ = arg;
3568             }
3569             else {
3570                 I32 prespace = 0;
3571                 bool ismore = FALSE;
3572
3573                 if (*s == '>') {
3574                     while (*++s == '>') ;
3575                     prespace = FF_SPACE;
3576                 }
3577                 else if (*s == '|') {
3578                     while (*++s == '|') ;
3579                     prespace = FF_HALFSPACE;
3580                     postspace = TRUE;
3581                 }
3582                 else {
3583                     if (*s == '<')
3584                         while (*++s == '<') ;
3585                     postspace = TRUE;
3586                 }
3587                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3588                     s += 3;
3589                     ismore = TRUE;
3590                 }
3591                 *fpc++ = s - base;              /* fieldsize for FETCH */
3592
3593                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3594
3595                 if (prespace)
3596                     *fpc++ = prespace;
3597                 *fpc++ = FF_ITEM;
3598                 if (ismore)
3599                     *fpc++ = FF_MORE;
3600                 if (ischop)
3601                     *fpc++ = FF_CHOP;
3602             }
3603             base = s;
3604             skipspaces = 0;
3605             continue;
3606         }
3607     }
3608     *fpc++ = FF_END;
3609
3610     arg = fpc - fops;
3611     { /* need to jump to the next word */
3612         int z;
3613         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3614         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3615         s = SvPVX(sv) + SvCUR(sv) + z;
3616     }
3617     Copy(fops, s, arg, U16);
3618     Safefree(fops);
3619     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3620     SvCOMPILED_on(sv);
3621 }
3622
3623 static I32
3624 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3625 {
3626     SV *datasv = FILTER_DATA(idx);
3627     int filter_has_file = IoLINES(datasv);
3628     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3629     SV *filter_state = (SV *)IoTOP_GV(datasv);
3630     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3631     int len = 0;
3632
3633     /* I was having segfault trouble under Linux 2.2.5 after a
3634        parse error occured.  (Had to hack around it with a test
3635        for PL_error_count == 0.)  Solaris doesn't segfault --
3636        not sure where the trouble is yet.  XXX */
3637
3638     if (filter_has_file) {
3639         len = FILTER_READ(idx+1, buf_sv, maxlen);
3640     }
3641
3642     if (filter_sub && len >= 0) {
3643         dSP;
3644         int count;
3645
3646         ENTER;
3647         SAVE_DEFSV;
3648         SAVETMPS;
3649         EXTEND(SP, 2);
3650
3651         DEFSV = buf_sv;
3652         PUSHMARK(SP);
3653         PUSHs(sv_2mortal(newSViv(maxlen)));
3654         if (filter_state) {
3655             PUSHs(filter_state);
3656         }
3657         PUTBACK;
3658         count = call_sv(filter_sub, G_SCALAR);
3659         SPAGAIN;
3660
3661         if (count > 0) {
3662             SV *out = POPs;
3663             if (SvOK(out)) {
3664                 len = SvIV(out);
3665             }
3666         }
3667
3668         PUTBACK;
3669         FREETMPS;
3670         LEAVE;
3671     }
3672
3673     if (len <= 0) {
3674         IoLINES(datasv) = 0;
3675         if (filter_child_proc) {
3676             SvREFCNT_dec(filter_child_proc);
3677             IoFMT_GV(datasv) = Nullgv;
3678         }
3679         if (filter_state) {
3680             SvREFCNT_dec(filter_state);
3681             IoTOP_GV(datasv) = Nullgv;
3682         }
3683         if (filter_sub) {
3684             SvREFCNT_dec(filter_sub);
3685             IoBOTTOM_GV(datasv) = Nullgv;
3686         }
3687         filter_del(run_user_filter);
3688     }
3689
3690     return len;
3691 }
3692
3693 /* perhaps someone can come up with a better name for
3694    this?  it is not really "absolute", per se ... */
3695 static bool
3696 S_path_is_absolute(pTHX_ char *name)
3697 {
3698     if (PERL_FILE_IS_ABSOLUTE(name)
3699 #ifdef MACOS_TRADITIONAL
3700         || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3701 #else
3702         || (*name == '.' && (name[1] == '/' ||
3703                              (name[1] == '.' && name[2] == '/'))))
3704 #endif
3705     {
3706         return TRUE;
3707     }
3708     else
3709         return FALSE;
3710 }