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