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     OP *retop;
2539     volatile PERL_SI *cursi = PL_curstackinfo;
2540     dJMPENV;
2541
2542 #ifdef DEBUGGING
2543     assert(CATCH_GET == TRUE);
2544 #endif
2545     PL_op = o;
2546
2547     /* Normally, the leavetry at the end of this block of ops will
2548      * pop an op off the return stack and continue there. By setting
2549      * the op to Nullop, we force an exit from the inner runops()
2550      * loop. DAPM.
2551      */
2552     retop = pop_return();
2553     push_return(Nullop);
2554
2555 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2556  redo_body:
2557     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2558 #else
2559     JMPENV_PUSH(ret);
2560 #endif
2561     switch (ret) {
2562     case 0:
2563 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2564  redo_body:
2565         docatch_body();
2566 #endif
2567         break;
2568     case 3:
2569         /* die caught by an inner eval - continue inner loop */
2570         if (PL_restartop && cursi == PL_curstackinfo) {
2571             PL_op = PL_restartop;
2572             PL_restartop = 0;
2573             goto redo_body;
2574         }
2575         /* a die in this eval - continue in outer loop */
2576         if (!PL_restartop)
2577             break;
2578         /* FALL THROUGH */
2579     default:
2580         JMPENV_POP;
2581         PL_op = oldop;
2582         JMPENV_JUMP(ret);
2583         /* NOTREACHED */
2584     }
2585     JMPENV_POP;
2586     PL_op = oldop;
2587     return retop;
2588 }
2589
2590 OP *
2591 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2592 /* sv Text to convert to OP tree. */
2593 /* startop op_free() this to undo. */
2594 /* code Short string id of the caller. */
2595 {
2596     dSP;                                /* Make POPBLOCK work. */
2597     PERL_CONTEXT *cx;
2598     SV **newsp;
2599     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2600     I32 optype;
2601     OP dummy;
2602     OP *rop;
2603     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2604     char *tmpbuf = tbuf;
2605     char *safestr;
2606
2607     ENTER;
2608     lex_start(sv);
2609     SAVETMPS;
2610     /* switch to eval mode */
2611
2612     if (PL_curcop == &PL_compiling) {
2613         SAVECOPSTASH_FREE(&PL_compiling);
2614         CopSTASH_set(&PL_compiling, PL_curstash);
2615     }
2616     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2617         SV *sv = sv_newmortal();
2618         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2619                        code, (unsigned long)++PL_evalseq,
2620                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2621         tmpbuf = SvPVX(sv);
2622     }
2623     else
2624         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2625     SAVECOPFILE_FREE(&PL_compiling);
2626     CopFILE_set(&PL_compiling, tmpbuf+2);
2627     SAVECOPLINE(&PL_compiling);
2628     CopLINE_set(&PL_compiling, 1);
2629     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2630        deleting the eval's FILEGV from the stash before gv_check() runs
2631        (i.e. before run-time proper). To work around the coredump that
2632        ensues, we always turn GvMULTI_on for any globals that were
2633        introduced within evals. See force_ident(). GSAR 96-10-12 */
2634     safestr = savepv(tmpbuf);
2635     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2636     SAVEHINTS();
2637 #ifdef OP_IN_REGISTER
2638     PL_opsave = op;
2639 #else
2640     SAVEVPTR(PL_op);
2641 #endif
2642     PL_hints &= HINT_UTF8;
2643
2644     PL_op = &dummy;
2645     PL_op->op_type = OP_ENTEREVAL;
2646     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2647     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2648     PUSHEVAL(cx, 0, Nullgv);
2649     rop = doeval(G_SCALAR, startop);
2650     POPBLOCK(cx,PL_curpm);
2651     POPEVAL(cx);
2652
2653     (*startop)->op_type = OP_NULL;
2654     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2655     lex_end();
2656     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2657     LEAVE;
2658     if (PL_curcop == &PL_compiling)
2659         PL_compiling.op_private = PL_hints;
2660 #ifdef OP_IN_REGISTER
2661     op = PL_opsave;
2662 #endif
2663     return rop;
2664 }
2665
2666 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2667 STATIC OP *
2668 S_doeval(pTHX_ int gimme, OP** startop)
2669 {
2670     dSP;
2671     OP *saveop = PL_op;
2672     CV *caller;
2673     AV* comppadlist;
2674     I32 i;
2675
2676     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2677                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2678                   : EVAL_INEVAL);
2679
2680     PUSHMARK(SP);
2681
2682     /* set up a scratch pad */
2683
2684     SAVEI32(PL_padix);
2685     SAVEVPTR(PL_curpad);
2686     SAVESPTR(PL_comppad);
2687     SAVESPTR(PL_comppad_name);
2688     SAVEI32(PL_comppad_name_fill);
2689     SAVEI32(PL_min_intro_pending);
2690     SAVEI32(PL_max_intro_pending);
2691
2692     caller = PL_compcv;
2693     for (i = cxstack_ix - 1; i >= 0; i--) {
2694         PERL_CONTEXT *cx = &cxstack[i];
2695         if (CxTYPE(cx) == CXt_EVAL)
2696             break;
2697         else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2698             caller = cx->blk_sub.cv;
2699             break;
2700         }
2701     }
2702
2703     SAVESPTR(PL_compcv);
2704     PL_compcv = (CV*)NEWSV(1104,0);
2705     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2706     CvEVAL_on(PL_compcv);
2707     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2708     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2709
2710 #ifdef USE_5005THREADS
2711     CvOWNER(PL_compcv) = 0;
2712     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2713     MUTEX_INIT(CvMUTEXP(PL_compcv));
2714 #endif /* USE_5005THREADS */
2715
2716     PL_comppad = newAV();
2717     av_push(PL_comppad, Nullsv);
2718     PL_curpad = AvARRAY(PL_comppad);
2719     PL_comppad_name = newAV();
2720     PL_comppad_name_fill = 0;
2721     PL_min_intro_pending = 0;
2722     PL_padix = 0;
2723 #ifdef USE_5005THREADS
2724     av_store(PL_comppad_name, 0, newSVpvn("@_", 2));
2725     PL_curpad[0] = (SV*)newAV();
2726     SvPADMY_on(PL_curpad[0]);   /* XXX Needed? */
2727 #endif /* USE_5005THREADS */
2728
2729     comppadlist = newAV();
2730     AvREAL_off(comppadlist);
2731     av_store(comppadlist, 0, (SV*)PL_comppad_name);
2732     av_store(comppadlist, 1, (SV*)PL_comppad);
2733     CvPADLIST(PL_compcv) = comppadlist;
2734
2735     if (!saveop ||
2736         (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2737     {
2738         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2739     }
2740
2741     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2742
2743     /* make sure we compile in the right package */
2744
2745     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2746         SAVESPTR(PL_curstash);
2747         PL_curstash = CopSTASH(PL_curcop);
2748     }
2749     SAVESPTR(PL_beginav);
2750     PL_beginav = newAV();
2751     SAVEFREESV(PL_beginav);
2752     SAVEI32(PL_error_count);
2753
2754     /* try to compile it */
2755
2756     PL_eval_root = Nullop;
2757     PL_error_count = 0;
2758     PL_curcop = &PL_compiling;
2759     PL_curcop->cop_arybase = 0;
2760     if (saveop && saveop->op_flags & OPf_SPECIAL)
2761         PL_in_eval |= EVAL_KEEPERR;
2762     else
2763         sv_setpv(ERRSV,"");
2764     if (yyparse() || PL_error_count || !PL_eval_root) {
2765         SV **newsp;
2766         I32 gimme;
2767         PERL_CONTEXT *cx;
2768         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2769         STRLEN n_a;
2770
2771         PL_op = saveop;
2772         if (PL_eval_root) {
2773             op_free(PL_eval_root);
2774             PL_eval_root = Nullop;
2775         }
2776         SP = PL_stack_base + POPMARK;           /* pop original mark */
2777         if (!startop) {
2778             POPBLOCK(cx,PL_curpm);
2779             POPEVAL(cx);
2780             pop_return();
2781         }
2782         lex_end();
2783         LEAVE;
2784         if (optype == OP_REQUIRE) {
2785             char* msg = SvPVx(ERRSV, n_a);
2786             DIE(aTHX_ "%sCompilation failed in require",
2787                 *msg ? msg : "Unknown error\n");
2788         }
2789         else if (startop) {
2790             char* msg = SvPVx(ERRSV, n_a);
2791
2792             POPBLOCK(cx,PL_curpm);
2793             POPEVAL(cx);
2794             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2795                        (*msg ? msg : "Unknown error\n"));
2796         }
2797 #ifdef USE_5005THREADS
2798         MUTEX_LOCK(&PL_eval_mutex);
2799         PL_eval_owner = 0;
2800         COND_SIGNAL(&PL_eval_cond);
2801         MUTEX_UNLOCK(&PL_eval_mutex);
2802 #endif /* USE_5005THREADS */
2803         RETPUSHUNDEF;
2804     }
2805     CopLINE_set(&PL_compiling, 0);
2806     if (startop) {
2807         *startop = PL_eval_root;
2808         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2809         CvOUTSIDE(PL_compcv) = Nullcv;
2810     } else
2811         SAVEFREEOP(PL_eval_root);
2812     if (gimme & G_VOID)
2813         scalarvoid(PL_eval_root);
2814     else if (gimme & G_ARRAY)
2815         list(PL_eval_root);
2816     else
2817         scalar(PL_eval_root);
2818
2819     DEBUG_x(dump_eval());
2820
2821     /* Register with debugger: */
2822     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2823         CV *cv = get_cv("DB::postponed", FALSE);
2824         if (cv) {
2825             dSP;
2826             PUSHMARK(SP);
2827             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2828             PUTBACK;
2829             call_sv((SV*)cv, G_DISCARD);
2830         }
2831     }
2832
2833     /* compiled okay, so do it */
2834
2835     CvDEPTH(PL_compcv) = 1;
2836     SP = PL_stack_base + POPMARK;               /* pop original mark */
2837     PL_op = saveop;                     /* The caller may need it. */
2838     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2839 #ifdef USE_5005THREADS
2840     MUTEX_LOCK(&PL_eval_mutex);
2841     PL_eval_owner = 0;
2842     COND_SIGNAL(&PL_eval_cond);
2843     MUTEX_UNLOCK(&PL_eval_mutex);
2844 #endif /* USE_5005THREADS */
2845
2846     RETURNOP(PL_eval_start);
2847 }
2848
2849 STATIC PerlIO *
2850 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2851 {
2852     STRLEN namelen = strlen(name);
2853     PerlIO *fp;
2854
2855     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2856         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2857         char *pmc = SvPV_nolen(pmcsv);
2858         Stat_t pmstat;
2859         Stat_t pmcstat;
2860         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2861             fp = PerlIO_open(name, mode);
2862         }
2863         else {
2864             if (PerlLIO_stat(name, &pmstat) < 0 ||
2865                 pmstat.st_mtime < pmcstat.st_mtime)
2866             {
2867                 fp = PerlIO_open(pmc, mode);
2868             }
2869             else {
2870                 fp = PerlIO_open(name, mode);
2871             }
2872         }
2873         SvREFCNT_dec(pmcsv);
2874     }
2875     else {
2876         fp = PerlIO_open(name, mode);
2877     }
2878     return fp;
2879 }
2880
2881 PP(pp_require)
2882 {
2883     dSP;
2884     register PERL_CONTEXT *cx;
2885     SV *sv;
2886     char *name;
2887     STRLEN len;
2888     char *tryname = Nullch;
2889     SV *namesv = Nullsv;
2890     SV** svp;
2891     I32 gimme = GIMME_V;
2892     PerlIO *tryrsfp = 0;
2893     STRLEN n_a;
2894     int filter_has_file = 0;
2895     GV *filter_child_proc = 0;
2896     SV *filter_state = 0;
2897     SV *filter_sub = 0;
2898     SV *hook_sv = 0;
2899     SV *encoding;
2900     OP *op;
2901
2902     sv = POPs;
2903     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2904         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2905             UV rev = 0, ver = 0, sver = 0;
2906             STRLEN len;
2907             U8 *s = (U8*)SvPVX(sv);
2908             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2909             if (s < end) {
2910                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2911                 s += len;
2912                 if (s < end) {
2913                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
2914                     s += len;
2915                     if (s < end)
2916                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
2917                 }
2918             }
2919             if (PERL_REVISION < rev
2920                 || (PERL_REVISION == rev
2921                     && (PERL_VERSION < ver
2922                         || (PERL_VERSION == ver
2923                             && PERL_SUBVERSION < sver))))
2924             {
2925                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2926                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2927                     PERL_VERSION, PERL_SUBVERSION);
2928             }
2929             if (ckWARN(WARN_PORTABLE))
2930                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2931                         "v-string in use/require non-portable");
2932             RETPUSHYES;
2933         }
2934         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
2935             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2936                 + ((NV)PERL_SUBVERSION/(NV)1000000)
2937                 + 0.00000099 < SvNV(sv))
2938             {
2939                 NV nrev = SvNV(sv);
2940                 UV rev = (UV)nrev;
2941                 NV nver = (nrev - rev) * 1000;
2942                 UV ver = (UV)(nver + 0.0009);
2943                 NV nsver = (nver - ver) * 1000;
2944                 UV sver = (UV)(nsver + 0.0009);
2945
2946                 /* help out with the "use 5.6" confusion */
2947                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2948                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2949                         "this is only v%d.%d.%d, stopped"
2950                         " (did you mean v%"UVuf".%03"UVuf"?)",
2951                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
2952                         PERL_SUBVERSION, rev, ver/100);
2953                 }
2954                 else {
2955                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2956                         "this is only v%d.%d.%d, stopped",
2957                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
2958                         PERL_SUBVERSION);
2959                 }
2960             }
2961             RETPUSHYES;
2962         }
2963     }
2964     name = SvPV(sv, len);
2965     if (!(name && len > 0 && *name))
2966         DIE(aTHX_ "Null filename used");
2967     TAINT_PROPER("require");
2968     if (PL_op->op_type == OP_REQUIRE &&
2969       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2970       *svp != &PL_sv_undef)
2971         RETPUSHYES;
2972
2973     /* prepare to compile file */
2974
2975     if (path_is_absolute(name)) {
2976         tryname = name;
2977         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2978     }
2979     if (!tryrsfp) {
2980         AV *ar = GvAVn(PL_incgv);
2981         I32 i;
2982 #ifdef VMS
2983         char *unixname;
2984         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2985 #endif
2986         {
2987             namesv = NEWSV(806, 0);
2988             for (i = 0; i <= AvFILL(ar); i++) {
2989                 SV *dirsv = *av_fetch(ar, i, TRUE);
2990
2991                 if (SvROK(dirsv)) {
2992                     int count;
2993                     SV *loader = dirsv;
2994
2995                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
2996                         && !sv_isobject(loader))
2997                     {
2998                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2999                     }
3000
3001                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3002                                    PTR2UV(SvRV(dirsv)), name);
3003                     tryname = SvPVX(namesv);
3004                     tryrsfp = 0;
3005
3006                     ENTER;
3007                     SAVETMPS;
3008                     EXTEND(SP, 2);
3009
3010                     PUSHMARK(SP);
3011                     PUSHs(dirsv);
3012                     PUSHs(sv);
3013                     PUTBACK;
3014                     if (sv_isobject(loader))
3015                         count = call_method("INC", G_ARRAY);
3016                     else
3017                         count = call_sv(loader, G_ARRAY);
3018                     SPAGAIN;
3019
3020                     if (count > 0) {
3021                         int i = 0;
3022                         SV *arg;
3023
3024                         SP -= count - 1;
3025                         arg = SP[i++];
3026
3027                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3028                             arg = SvRV(arg);
3029                         }
3030
3031                         if (SvTYPE(arg) == SVt_PVGV) {
3032                             IO *io = GvIO((GV *)arg);
3033
3034                             ++filter_has_file;
3035
3036                             if (io) {
3037                                 tryrsfp = IoIFP(io);
3038                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3039                                     /* reading from a child process doesn't
3040                                        nest -- when returning from reading
3041                                        the inner module, the outer one is
3042                                        unreadable (closed?)  I've tried to
3043                                        save the gv to manage the lifespan of
3044                                        the pipe, but this didn't help. XXX */
3045                                     filter_child_proc = (GV *)arg;
3046                                     (void)SvREFCNT_inc(filter_child_proc);
3047                                 }
3048                                 else {
3049                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3050                                         PerlIO_close(IoOFP(io));
3051                                     }
3052                                     IoIFP(io) = Nullfp;
3053                                     IoOFP(io) = Nullfp;
3054                                 }
3055                             }
3056
3057                             if (i < count) {
3058                                 arg = SP[i++];
3059                             }
3060                         }
3061
3062                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3063                             filter_sub = arg;
3064                             (void)SvREFCNT_inc(filter_sub);
3065
3066                             if (i < count) {
3067                                 filter_state = SP[i];
3068                                 (void)SvREFCNT_inc(filter_state);
3069                             }
3070
3071                             if (tryrsfp == 0) {
3072                                 tryrsfp = PerlIO_open("/dev/null",
3073                                                       PERL_SCRIPT_MODE);
3074                             }
3075                         }
3076                     }
3077
3078                     PUTBACK;
3079                     FREETMPS;
3080                     LEAVE;
3081
3082                     if (tryrsfp) {
3083                         hook_sv = dirsv;
3084                         break;
3085                     }
3086
3087                     filter_has_file = 0;
3088                     if (filter_child_proc) {
3089                         SvREFCNT_dec(filter_child_proc);
3090                         filter_child_proc = 0;
3091                     }
3092                     if (filter_state) {
3093                         SvREFCNT_dec(filter_state);
3094                         filter_state = 0;
3095                     }
3096                     if (filter_sub) {
3097                         SvREFCNT_dec(filter_sub);
3098                         filter_sub = 0;
3099                     }
3100                 }
3101                 else {
3102                   if (!path_is_absolute(name)
3103 #ifdef MACOS_TRADITIONAL
3104                         /* We consider paths of the form :a:b ambiguous and interpret them first
3105                            as global then as local
3106                         */
3107                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3108 #endif
3109                   ) {
3110                     char *dir = SvPVx(dirsv, n_a);
3111 #ifdef MACOS_TRADITIONAL
3112                     char buf[256];
3113                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
3114 #else
3115 #ifdef VMS
3116                     char *unixdir;
3117                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3118                         continue;
3119                     sv_setpv(namesv, unixdir);
3120                     sv_catpv(namesv, unixname);
3121 #else
3122                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3123 #endif
3124 #endif
3125                     TAINT_PROPER("require");
3126                     tryname = SvPVX(namesv);
3127 #ifdef MACOS_TRADITIONAL
3128                     {
3129                         /* Convert slashes in the name part, but not the directory part, to colons */
3130                         char * colon;
3131                         for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
3132                             *colon++ = ':';
3133                     }
3134 #endif
3135                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3136                     if (tryrsfp) {
3137                         if (tryname[0] == '.' && tryname[1] == '/')
3138                             tryname += 2;
3139                         break;
3140                     }
3141                   }
3142                 }
3143             }
3144         }
3145     }
3146     SAVECOPFILE_FREE(&PL_compiling);
3147     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3148     SvREFCNT_dec(namesv);
3149     if (!tryrsfp) {
3150         if (PL_op->op_type == OP_REQUIRE) {
3151             char *msgstr = name;
3152             if (namesv) {                       /* did we lookup @INC? */
3153                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3154                 SV *dirmsgsv = NEWSV(0, 0);
3155                 AV *ar = GvAVn(PL_incgv);
3156                 I32 i;
3157                 sv_catpvn(msg, " in @INC", 8);
3158                 if (instr(SvPVX(msg), ".h "))
3159                     sv_catpv(msg, " (change .h to .ph maybe?)");
3160                 if (instr(SvPVX(msg), ".ph "))
3161                     sv_catpv(msg, " (did you run h2ph?)");
3162                 sv_catpv(msg, " (@INC contains:");
3163                 for (i = 0; i <= AvFILL(ar); i++) {
3164                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3165                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3166                     sv_catsv(msg, dirmsgsv);
3167                 }
3168                 sv_catpvn(msg, ")", 1);
3169                 SvREFCNT_dec(dirmsgsv);
3170                 msgstr = SvPV_nolen(msg);
3171             }
3172             DIE(aTHX_ "Can't locate %s", msgstr);
3173         }
3174
3175         RETPUSHUNDEF;
3176     }
3177     else
3178         SETERRNO(0, SS$_NORMAL);
3179
3180     /* Assume success here to prevent recursive requirement. */
3181     len = strlen(name);
3182     /* Check whether a hook in @INC has already filled %INC */
3183     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3184         (void)hv_store(GvHVn(PL_incgv), name, len,
3185                        (hook_sv ? SvREFCNT_inc(hook_sv)
3186                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3187                        0 );
3188     }
3189
3190     ENTER;
3191     SAVETMPS;
3192     lex_start(sv_2mortal(newSVpvn("",0)));
3193     SAVEGENERICSV(PL_rsfp_filters);
3194     PL_rsfp_filters = Nullav;
3195
3196     PL_rsfp = tryrsfp;
3197     SAVEHINTS();
3198     PL_hints = 0;
3199     SAVESPTR(PL_compiling.cop_warnings);
3200     if (PL_dowarn & G_WARN_ALL_ON)
3201         PL_compiling.cop_warnings = pWARN_ALL ;
3202     else if (PL_dowarn & G_WARN_ALL_OFF)
3203         PL_compiling.cop_warnings = pWARN_NONE ;
3204     else if (PL_taint_warn)
3205         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3206     else
3207         PL_compiling.cop_warnings = pWARN_STD ;
3208     SAVESPTR(PL_compiling.cop_io);
3209     PL_compiling.cop_io = Nullsv;
3210
3211     if (filter_sub || filter_child_proc) {
3212         SV *datasv = filter_add(run_user_filter, Nullsv);
3213         IoLINES(datasv) = filter_has_file;
3214         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3215         IoTOP_GV(datasv) = (GV *)filter_state;
3216         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3217     }
3218
3219     /* switch to eval mode */
3220     push_return(PL_op->op_next);
3221     PUSHBLOCK(cx, CXt_EVAL, SP);
3222     PUSHEVAL(cx, name, Nullgv);
3223
3224     SAVECOPLINE(&PL_compiling);
3225     CopLINE_set(&PL_compiling, 0);
3226
3227     PUTBACK;
3228 #ifdef USE_5005THREADS
3229     MUTEX_LOCK(&PL_eval_mutex);
3230     if (PL_eval_owner && PL_eval_owner != thr)
3231         while (PL_eval_owner)
3232             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3233     PL_eval_owner = thr;
3234     MUTEX_UNLOCK(&PL_eval_mutex);
3235 #endif /* USE_5005THREADS */
3236
3237     /* Store and reset encoding. */
3238     encoding = PL_encoding;
3239     PL_encoding = Nullsv;
3240
3241     op = DOCATCH(doeval(gimme, NULL));
3242
3243     /* Restore encoding. */
3244     PL_encoding = encoding;
3245
3246     return op;
3247 }
3248
3249 PP(pp_dofile)
3250 {
3251     return pp_require();
3252 }
3253
3254 PP(pp_entereval)
3255 {
3256     dSP;
3257     register PERL_CONTEXT *cx;
3258     dPOPss;
3259     I32 gimme = GIMME_V, was = PL_sub_generation;
3260     char tbuf[TYPE_DIGITS(long) + 12];
3261     char *tmpbuf = tbuf;
3262     char *safestr;
3263     STRLEN len;
3264     OP *ret;
3265
3266     if (!SvPV(sv,len) || !len)
3267         RETPUSHUNDEF;
3268     TAINT_PROPER("eval");
3269
3270     ENTER;
3271     lex_start(sv);
3272     SAVETMPS;
3273
3274     /* switch to eval mode */
3275
3276     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3277         SV *sv = sv_newmortal();
3278         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3279                        (unsigned long)++PL_evalseq,
3280                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3281         tmpbuf = SvPVX(sv);
3282     }
3283     else
3284         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3285     SAVECOPFILE_FREE(&PL_compiling);
3286     CopFILE_set(&PL_compiling, tmpbuf+2);
3287     SAVECOPLINE(&PL_compiling);
3288     CopLINE_set(&PL_compiling, 1);
3289     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3290        deleting the eval's FILEGV from the stash before gv_check() runs
3291        (i.e. before run-time proper). To work around the coredump that
3292        ensues, we always turn GvMULTI_on for any globals that were
3293        introduced within evals. See force_ident(). GSAR 96-10-12 */
3294     safestr = savepv(tmpbuf);
3295     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3296     SAVEHINTS();
3297     PL_hints = PL_op->op_targ;
3298     SAVESPTR(PL_compiling.cop_warnings);
3299     if (specialWARN(PL_curcop->cop_warnings))
3300         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3301     else {
3302         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3303         SAVEFREESV(PL_compiling.cop_warnings);
3304     }
3305     SAVESPTR(PL_compiling.cop_io);
3306     if (specialCopIO(PL_curcop->cop_io))
3307         PL_compiling.cop_io = PL_curcop->cop_io;
3308     else {
3309         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3310         SAVEFREESV(PL_compiling.cop_io);
3311     }
3312
3313     push_return(PL_op->op_next);
3314     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3315     PUSHEVAL(cx, 0, Nullgv);
3316
3317     /* prepare to compile string */
3318
3319     if (PERLDB_LINE && PL_curstash != PL_debstash)
3320         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3321     PUTBACK;
3322 #ifdef USE_5005THREADS
3323     MUTEX_LOCK(&PL_eval_mutex);
3324     if (PL_eval_owner && PL_eval_owner != thr)
3325         while (PL_eval_owner)
3326             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3327     PL_eval_owner = thr;
3328     MUTEX_UNLOCK(&PL_eval_mutex);
3329 #endif /* USE_5005THREADS */
3330     ret = doeval(gimme, NULL);
3331     if (PERLDB_INTER && was != PL_sub_generation /* Some subs defined here. */
3332         && ret != PL_op->op_next) {     /* Successive compilation. */
3333         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3334     }
3335     return DOCATCH(ret);
3336 }
3337
3338 PP(pp_leaveeval)
3339 {
3340     dSP;
3341     register SV **mark;
3342     SV **newsp;
3343     PMOP *newpm;
3344     I32 gimme;
3345     register PERL_CONTEXT *cx;
3346     OP *retop;
3347     U8 save_flags = PL_op -> op_flags;
3348     I32 optype;
3349
3350     POPBLOCK(cx,newpm);
3351     POPEVAL(cx);
3352     retop = pop_return();
3353
3354     TAINT_NOT;
3355     if (gimme == G_VOID)
3356         MARK = newsp;
3357     else if (gimme == G_SCALAR) {
3358         MARK = newsp + 1;
3359         if (MARK <= SP) {
3360             if (SvFLAGS(TOPs) & SVs_TEMP)
3361                 *MARK = TOPs;
3362             else
3363                 *MARK = sv_mortalcopy(TOPs);
3364         }
3365         else {
3366             MEXTEND(mark,0);
3367             *MARK = &PL_sv_undef;
3368         }
3369         SP = MARK;
3370     }
3371     else {
3372         /* in case LEAVE wipes old return values */
3373         for (mark = newsp + 1; mark <= SP; mark++) {
3374             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3375                 *mark = sv_mortalcopy(*mark);
3376                 TAINT_NOT;      /* Each item is independent */
3377             }
3378         }
3379     }
3380     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3381
3382 #ifdef DEBUGGING
3383     assert(CvDEPTH(PL_compcv) == 1);
3384 #endif
3385     CvDEPTH(PL_compcv) = 0;
3386     lex_end();
3387
3388     if (optype == OP_REQUIRE &&
3389         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3390     {
3391         /* Unassume the success we assumed earlier. */
3392         SV *nsv = cx->blk_eval.old_namesv;
3393         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3394         retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3395         /* die_where() did LEAVE, or we won't be here */
3396     }
3397     else {
3398         LEAVE;
3399         if (!(save_flags & OPf_SPECIAL))
3400             sv_setpv(ERRSV,"");
3401     }
3402
3403     RETURNOP(retop);
3404 }
3405
3406 PP(pp_entertry)
3407 {
3408     dSP;
3409     register PERL_CONTEXT *cx;
3410     I32 gimme = GIMME_V;
3411
3412     ENTER;
3413     SAVETMPS;
3414
3415     push_return(cLOGOP->op_other->op_next);
3416     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3417     PUSHEVAL(cx, 0, 0);
3418
3419     PL_in_eval = EVAL_INEVAL;
3420     sv_setpv(ERRSV,"");
3421     PUTBACK;
3422     return DOCATCH(PL_op->op_next);
3423 }
3424
3425 PP(pp_leavetry)
3426 {
3427     dSP;
3428     register SV **mark;
3429     SV **newsp;
3430     PMOP *newpm;
3431     OP* retop;
3432     I32 gimme;
3433     register PERL_CONTEXT *cx;
3434     I32 optype;
3435
3436     POPBLOCK(cx,newpm);
3437     POPEVAL(cx);
3438     retop = pop_return();
3439
3440     TAINT_NOT;
3441     if (gimme == G_VOID)
3442         SP = newsp;
3443     else if (gimme == G_SCALAR) {
3444         MARK = newsp + 1;
3445         if (MARK <= SP) {
3446             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3447                 *MARK = TOPs;
3448             else
3449                 *MARK = sv_mortalcopy(TOPs);
3450         }
3451         else {
3452             MEXTEND(mark,0);
3453             *MARK = &PL_sv_undef;
3454         }
3455         SP = MARK;
3456     }
3457     else {
3458         /* in case LEAVE wipes old return values */
3459         for (mark = newsp + 1; mark <= SP; mark++) {
3460             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3461                 *mark = sv_mortalcopy(*mark);
3462                 TAINT_NOT;      /* Each item is independent */
3463             }
3464         }
3465     }
3466     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3467
3468     LEAVE;
3469     sv_setpv(ERRSV,"");
3470     RETURNOP(retop);
3471 }
3472
3473 STATIC void
3474 S_doparseform(pTHX_ SV *sv)
3475 {
3476     STRLEN len;
3477     register char *s = SvPV_force(sv, len);
3478     register char *send = s + len;
3479     register char *base = Nullch;
3480     register I32 skipspaces = 0;
3481     bool noblank   = FALSE;
3482     bool repeat    = FALSE;
3483     bool postspace = FALSE;
3484     U16 *fops;
3485     register U16 *fpc;
3486     U16 *linepc = 0;
3487     register I32 arg;
3488     bool ischop;
3489
3490     if (len == 0)
3491         Perl_croak(aTHX_ "Null picture in formline");
3492
3493     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3494     fpc = fops;
3495
3496     if (s < send) {
3497         linepc = fpc;
3498         *fpc++ = FF_LINEMARK;
3499         noblank = repeat = FALSE;
3500         base = s;
3501     }
3502
3503     while (s <= send) {
3504         switch (*s++) {
3505         default:
3506             skipspaces = 0;
3507             continue;
3508
3509         case '~':
3510             if (*s == '~') {
3511                 repeat = TRUE;
3512                 *s = ' ';
3513             }
3514             noblank = TRUE;
3515             s[-1] = ' ';
3516             /* FALL THROUGH */
3517         case ' ': case '\t':
3518             skipspaces++;
3519             continue;
3520
3521         case '\n': case 0:
3522             arg = s - base;
3523             skipspaces++;
3524             arg -= skipspaces;
3525             if (arg) {
3526                 if (postspace)
3527                     *fpc++ = FF_SPACE;
3528                 *fpc++ = FF_LITERAL;
3529                 *fpc++ = arg;
3530             }
3531             postspace = FALSE;
3532             if (s <= send)
3533                 skipspaces--;
3534             if (skipspaces) {
3535                 *fpc++ = FF_SKIP;
3536                 *fpc++ = skipspaces;
3537             }
3538             skipspaces = 0;
3539             if (s <= send)
3540                 *fpc++ = FF_NEWLINE;
3541             if (noblank) {
3542                 *fpc++ = FF_BLANK;
3543                 if (repeat)
3544                     arg = fpc - linepc + 1;
3545                 else
3546                     arg = 0;
3547                 *fpc++ = arg;
3548             }
3549             if (s < send) {
3550                 linepc = fpc;
3551                 *fpc++ = FF_LINEMARK;
3552                 noblank = repeat = FALSE;
3553                 base = s;
3554             }
3555             else
3556                 s++;
3557             continue;
3558
3559         case '@':
3560         case '^':
3561             ischop = s[-1] == '^';
3562
3563             if (postspace) {
3564                 *fpc++ = FF_SPACE;
3565                 postspace = FALSE;
3566             }
3567             arg = (s - base) - 1;
3568             if (arg) {
3569                 *fpc++ = FF_LITERAL;
3570                 *fpc++ = arg;
3571             }
3572
3573             base = s - 1;
3574             *fpc++ = FF_FETCH;
3575             if (*s == '*') {
3576                 s++;
3577                 *fpc++ = 0;
3578                 *fpc++ = FF_LINEGLOB;
3579             }
3580             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3581                 arg = ischop ? 512 : 0;
3582                 base = s - 1;
3583                 while (*s == '#')
3584                     s++;
3585                 if (*s == '.') {
3586                     char *f;
3587                     s++;
3588                     f = s;
3589                     while (*s == '#')
3590                         s++;
3591                     arg |= 256 + (s - f);
3592                 }
3593                 *fpc++ = s - base;              /* fieldsize for FETCH */
3594                 *fpc++ = FF_DECIMAL;
3595                 *fpc++ = arg;
3596             }
3597             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3598                 arg = ischop ? 512 : 0;
3599                 base = s - 1;
3600                 s++;                                /* skip the '0' first */
3601                 while (*s == '#')
3602                     s++;
3603                 if (*s == '.') {
3604                     char *f;
3605                     s++;
3606                     f = s;
3607                     while (*s == '#')
3608                         s++;
3609                     arg |= 256 + (s - f);
3610                 }
3611                 *fpc++ = s - base;                /* fieldsize for FETCH */
3612                 *fpc++ = FF_0DECIMAL;
3613                 *fpc++ = arg;
3614             }
3615             else {
3616                 I32 prespace = 0;
3617                 bool ismore = FALSE;
3618
3619                 if (*s == '>') {
3620                     while (*++s == '>') ;
3621                     prespace = FF_SPACE;
3622                 }
3623                 else if (*s == '|') {
3624                     while (*++s == '|') ;
3625                     prespace = FF_HALFSPACE;
3626                     postspace = TRUE;
3627                 }
3628                 else {
3629                     if (*s == '<')
3630                         while (*++s == '<') ;
3631                     postspace = TRUE;
3632                 }
3633                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3634                     s += 3;
3635                     ismore = TRUE;
3636                 }
3637                 *fpc++ = s - base;              /* fieldsize for FETCH */
3638
3639                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3640
3641                 if (prespace)
3642                     *fpc++ = prespace;
3643                 *fpc++ = FF_ITEM;
3644                 if (ismore)
3645                     *fpc++ = FF_MORE;
3646                 if (ischop)
3647                     *fpc++ = FF_CHOP;
3648             }
3649             base = s;
3650             skipspaces = 0;
3651             continue;
3652         }
3653     }
3654     *fpc++ = FF_END;
3655
3656     arg = fpc - fops;
3657     { /* need to jump to the next word */
3658         int z;
3659         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3660         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3661         s = SvPVX(sv) + SvCUR(sv) + z;
3662     }
3663     Copy(fops, s, arg, U16);
3664     Safefree(fops);
3665     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3666     SvCOMPILED_on(sv);
3667 }
3668
3669 static I32
3670 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3671 {
3672     SV *datasv = FILTER_DATA(idx);
3673     int filter_has_file = IoLINES(datasv);
3674     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3675     SV *filter_state = (SV *)IoTOP_GV(datasv);
3676     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3677     int len = 0;
3678
3679     /* I was having segfault trouble under Linux 2.2.5 after a
3680        parse error occured.  (Had to hack around it with a test
3681        for PL_error_count == 0.)  Solaris doesn't segfault --
3682        not sure where the trouble is yet.  XXX */
3683
3684     if (filter_has_file) {
3685         len = FILTER_READ(idx+1, buf_sv, maxlen);
3686     }
3687
3688     if (filter_sub && len >= 0) {
3689         dSP;
3690         int count;
3691
3692         ENTER;
3693         SAVE_DEFSV;
3694         SAVETMPS;
3695         EXTEND(SP, 2);
3696
3697         DEFSV = buf_sv;
3698         PUSHMARK(SP);
3699         PUSHs(sv_2mortal(newSViv(maxlen)));
3700         if (filter_state) {
3701             PUSHs(filter_state);
3702         }
3703         PUTBACK;
3704         count = call_sv(filter_sub, G_SCALAR);
3705         SPAGAIN;
3706
3707         if (count > 0) {
3708             SV *out = POPs;
3709             if (SvOK(out)) {
3710                 len = SvIV(out);
3711             }
3712         }
3713
3714         PUTBACK;
3715         FREETMPS;
3716         LEAVE;
3717     }
3718
3719     if (len <= 0) {
3720         IoLINES(datasv) = 0;
3721         if (filter_child_proc) {
3722             SvREFCNT_dec(filter_child_proc);
3723             IoFMT_GV(datasv) = Nullgv;
3724         }
3725         if (filter_state) {
3726             SvREFCNT_dec(filter_state);
3727             IoTOP_GV(datasv) = Nullgv;
3728         }
3729         if (filter_sub) {
3730             SvREFCNT_dec(filter_sub);
3731             IoBOTTOM_GV(datasv) = Nullgv;
3732         }
3733         filter_del(run_user_filter);
3734     }
3735
3736     return len;
3737 }
3738
3739 /* perhaps someone can come up with a better name for
3740    this?  it is not really "absolute", per se ... */
3741 static bool
3742 S_path_is_absolute(pTHX_ char *name)
3743 {
3744     if (PERL_FILE_IS_ABSOLUTE(name)
3745 #ifdef MACOS_TRADITIONAL
3746         || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
3747 #else
3748         || (*name == '.' && (name[1] == '/' ||
3749                              (name[1] == '.' && name[2] == '/'))))
3750 #endif
3751     {
3752         return TRUE;
3753     }
3754     else
3755         return FALSE;
3756 }