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