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