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