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