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         RETPUSHUNDEF;
2736     }
2737     CopLINE_set(&PL_compiling, 0);
2738     if (startop) {
2739         *startop = PL_eval_root;
2740         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2741         CvOUTSIDE(PL_compcv) = Nullcv;
2742     } else
2743         SAVEFREEOP(PL_eval_root);
2744     if (gimme & G_VOID)
2745         scalarvoid(PL_eval_root);
2746     else if (gimme & G_ARRAY)
2747         list(PL_eval_root);
2748     else
2749         scalar(PL_eval_root);
2750
2751     DEBUG_x(dump_eval());
2752
2753     /* Register with debugger: */
2754     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2755         CV *cv = get_cv("DB::postponed", FALSE);
2756         if (cv) {
2757             dSP;
2758             PUSHMARK(SP);
2759             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2760             PUTBACK;
2761             call_sv((SV*)cv, G_DISCARD);
2762         }
2763     }
2764
2765     /* compiled okay, so do it */
2766
2767     CvDEPTH(PL_compcv) = 1;
2768     SP = PL_stack_base + POPMARK;               /* pop original mark */
2769     PL_op = saveop;                     /* The caller may need it. */
2770     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2771
2772     RETURNOP(PL_eval_start);
2773 }
2774
2775 STATIC PerlIO *
2776 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2777 {
2778     STRLEN namelen = strlen(name);
2779     PerlIO *fp;
2780
2781     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2782         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2783         char *pmc = SvPV_nolen(pmcsv);
2784         Stat_t pmstat;
2785         Stat_t pmcstat;
2786         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2787             fp = PerlIO_open(name, mode);
2788         }
2789         else {
2790             if (PerlLIO_stat(name, &pmstat) < 0 ||
2791                 pmstat.st_mtime < pmcstat.st_mtime)
2792             {
2793                 fp = PerlIO_open(pmc, mode);
2794             }
2795             else {
2796                 fp = PerlIO_open(name, mode);
2797             }
2798         }
2799         SvREFCNT_dec(pmcsv);
2800     }
2801     else {
2802         fp = PerlIO_open(name, mode);
2803     }
2804     return fp;
2805 }
2806
2807 PP(pp_require)
2808 {
2809     dSP;
2810     register PERL_CONTEXT *cx;
2811     SV *sv;
2812     char *name;
2813     STRLEN len;
2814     char *tryname = Nullch;
2815     SV *namesv = Nullsv;
2816     SV** svp;
2817     I32 gimme = GIMME_V;
2818     PerlIO *tryrsfp = 0;
2819     STRLEN n_a;
2820     int filter_has_file = 0;
2821     GV *filter_child_proc = 0;
2822     SV *filter_state = 0;
2823     SV *filter_sub = 0;
2824     SV *hook_sv = 0;
2825     SV *encoding;
2826     OP *op;
2827
2828     sv = POPs;
2829     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2830         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2831             UV rev = 0, ver = 0, sver = 0;
2832             STRLEN len;
2833             U8 *s = (U8*)SvPVX(sv);
2834             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2835             if (s < end) {
2836                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2837                 s += len;
2838                 if (s < end) {
2839                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
2840                     s += len;
2841                     if (s < end)
2842                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
2843                 }
2844             }
2845             if (PERL_REVISION < rev
2846                 || (PERL_REVISION == rev
2847                     && (PERL_VERSION < ver
2848                         || (PERL_VERSION == ver
2849                             && PERL_SUBVERSION < sver))))
2850             {
2851                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2852                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2853                     PERL_VERSION, PERL_SUBVERSION);
2854             }
2855             if (ckWARN(WARN_PORTABLE))
2856                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2857                         "v-string in use/require non-portable");
2858             RETPUSHYES;
2859         }
2860         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
2861             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2862                 + ((NV)PERL_SUBVERSION/(NV)1000000)
2863                 + 0.00000099 < SvNV(sv))
2864             {
2865                 NV nrev = SvNV(sv);
2866                 UV rev = (UV)nrev;
2867                 NV nver = (nrev - rev) * 1000;
2868                 UV ver = (UV)(nver + 0.0009);
2869                 NV nsver = (nver - ver) * 1000;
2870                 UV sver = (UV)(nsver + 0.0009);
2871
2872                 /* help out with the "use 5.6" confusion */
2873                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2874                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2875                         " (did you mean v%"UVuf".%03"UVuf"?)--"
2876                         "this is only v%d.%d.%d, stopped",
2877                         rev, ver, sver, rev, ver/100,
2878                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2879                 }
2880                 else {
2881                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2882                         "this is only v%d.%d.%d, stopped",
2883                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
2884                         PERL_SUBVERSION);
2885                 }
2886             }
2887             RETPUSHYES;
2888         }
2889     }
2890     name = SvPV(sv, len);
2891     if (!(name && len > 0 && *name))
2892         DIE(aTHX_ "Null filename used");
2893     TAINT_PROPER("require");
2894     if (PL_op->op_type == OP_REQUIRE &&
2895       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2896       *svp != &PL_sv_undef)
2897         RETPUSHYES;
2898
2899     /* prepare to compile file */
2900
2901     if (path_is_absolute(name)) {
2902         tryname = name;
2903         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2904     }
2905 #ifdef MACOS_TRADITIONAL
2906     if (!tryrsfp) {
2907         char newname[256];
2908
2909         MacPerl_CanonDir(name, newname, 1);
2910         if (path_is_absolute(newname)) {
2911             tryname = newname;
2912             tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2913         }
2914     }
2915 #endif
2916     if (!tryrsfp) {
2917         AV *ar = GvAVn(PL_incgv);
2918         I32 i;
2919 #ifdef VMS
2920         char *unixname;
2921         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2922 #endif
2923         {
2924             namesv = NEWSV(806, 0);
2925             for (i = 0; i <= AvFILL(ar); i++) {
2926                 SV *dirsv = *av_fetch(ar, i, TRUE);
2927
2928                 if (SvROK(dirsv)) {
2929                     int count;
2930                     SV *loader = dirsv;
2931
2932                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
2933                         && !sv_isobject(loader))
2934                     {
2935                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2936                     }
2937
2938                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2939                                    PTR2UV(SvRV(dirsv)), name);
2940                     tryname = SvPVX(namesv);
2941                     tryrsfp = 0;
2942
2943                     ENTER;
2944                     SAVETMPS;
2945                     EXTEND(SP, 2);
2946
2947                     PUSHMARK(SP);
2948                     PUSHs(dirsv);
2949                     PUSHs(sv);
2950                     PUTBACK;
2951                     if (sv_isobject(loader))
2952                         count = call_method("INC", G_ARRAY);
2953                     else
2954                         count = call_sv(loader, G_ARRAY);
2955                     SPAGAIN;
2956
2957                     if (count > 0) {
2958                         int i = 0;
2959                         SV *arg;
2960
2961                         SP -= count - 1;
2962                         arg = SP[i++];
2963
2964                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
2965                             arg = SvRV(arg);
2966                         }
2967
2968                         if (SvTYPE(arg) == SVt_PVGV) {
2969                             IO *io = GvIO((GV *)arg);
2970
2971                             ++filter_has_file;
2972
2973                             if (io) {
2974                                 tryrsfp = IoIFP(io);
2975                                 if (IoTYPE(io) == IoTYPE_PIPE) {
2976                                     /* reading from a child process doesn't
2977                                        nest -- when returning from reading
2978                                        the inner module, the outer one is
2979                                        unreadable (closed?)  I've tried to
2980                                        save the gv to manage the lifespan of
2981                                        the pipe, but this didn't help. XXX */
2982                                     filter_child_proc = (GV *)arg;
2983                                     (void)SvREFCNT_inc(filter_child_proc);
2984                                 }
2985                                 else {
2986                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
2987                                         PerlIO_close(IoOFP(io));
2988                                     }
2989                                     IoIFP(io) = Nullfp;
2990                                     IoOFP(io) = Nullfp;
2991                                 }
2992                             }
2993
2994                             if (i < count) {
2995                                 arg = SP[i++];
2996                             }
2997                         }
2998
2999                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3000                             filter_sub = arg;
3001                             (void)SvREFCNT_inc(filter_sub);
3002
3003                             if (i < count) {
3004                                 filter_state = SP[i];
3005                                 (void)SvREFCNT_inc(filter_state);
3006                             }
3007
3008                             if (tryrsfp == 0) {
3009                                 tryrsfp = PerlIO_open("/dev/null",
3010                                                       PERL_SCRIPT_MODE);
3011                             }
3012                         }
3013                     }
3014
3015                     PUTBACK;
3016                     FREETMPS;
3017                     LEAVE;
3018
3019                     if (tryrsfp) {
3020                         hook_sv = dirsv;
3021                         break;
3022                     }
3023
3024                     filter_has_file = 0;
3025                     if (filter_child_proc) {
3026                         SvREFCNT_dec(filter_child_proc);
3027                         filter_child_proc = 0;
3028                     }
3029                     if (filter_state) {
3030                         SvREFCNT_dec(filter_state);
3031                         filter_state = 0;
3032                     }
3033                     if (filter_sub) {
3034                         SvREFCNT_dec(filter_sub);
3035                         filter_sub = 0;
3036                     }
3037                 }
3038                 else {
3039                   if (!path_is_absolute(name)
3040 #ifdef MACOS_TRADITIONAL
3041                         /* We consider paths of the form :a:b ambiguous and interpret them first
3042                            as global then as local
3043                         */
3044                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3045 #endif
3046                   ) {
3047                     char *dir = SvPVx(dirsv, n_a);
3048 #ifdef MACOS_TRADITIONAL
3049                     char buf1[256];
3050                     char buf2[256];
3051
3052                     MacPerl_CanonDir(name, buf2, 1);
3053                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3054 #else
3055 #ifdef VMS
3056                     char *unixdir;
3057                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3058                         continue;
3059                     sv_setpv(namesv, unixdir);
3060                     sv_catpv(namesv, unixname);
3061 #else
3062                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3063 #endif
3064 #endif
3065                     TAINT_PROPER("require");
3066                     tryname = SvPVX(namesv);
3067                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3068                     if (tryrsfp) {
3069                         if (tryname[0] == '.' && tryname[1] == '/')
3070                             tryname += 2;
3071                         break;
3072                     }
3073                   }
3074                 }
3075             }
3076         }
3077     }
3078     SAVECOPFILE_FREE(&PL_compiling);
3079     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3080     SvREFCNT_dec(namesv);
3081     if (!tryrsfp) {
3082         if (PL_op->op_type == OP_REQUIRE) {
3083             char *msgstr = name;
3084             if (namesv) {                       /* did we lookup @INC? */
3085                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3086                 SV *dirmsgsv = NEWSV(0, 0);
3087                 AV *ar = GvAVn(PL_incgv);
3088                 I32 i;
3089                 sv_catpvn(msg, " in @INC", 8);
3090                 if (instr(SvPVX(msg), ".h "))
3091                     sv_catpv(msg, " (change .h to .ph maybe?)");
3092                 if (instr(SvPVX(msg), ".ph "))
3093                     sv_catpv(msg, " (did you run h2ph?)");
3094                 sv_catpv(msg, " (@INC contains:");
3095                 for (i = 0; i <= AvFILL(ar); i++) {
3096                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3097                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3098                     sv_catsv(msg, dirmsgsv);
3099                 }
3100                 sv_catpvn(msg, ")", 1);
3101                 SvREFCNT_dec(dirmsgsv);
3102                 msgstr = SvPV_nolen(msg);
3103             }
3104             DIE(aTHX_ "Can't locate %s", msgstr);
3105         }
3106
3107         RETPUSHUNDEF;
3108     }
3109     else
3110         SETERRNO(0, SS_NORMAL);
3111
3112     /* Assume success here to prevent recursive requirement. */
3113     len = strlen(name);
3114     /* Check whether a hook in @INC has already filled %INC */
3115     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3116         (void)hv_store(GvHVn(PL_incgv), name, len,
3117                        (hook_sv ? SvREFCNT_inc(hook_sv)
3118                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3119                        0 );
3120     }
3121
3122     ENTER;
3123     SAVETMPS;
3124     lex_start(sv_2mortal(newSVpvn("",0)));
3125     SAVEGENERICSV(PL_rsfp_filters);
3126     PL_rsfp_filters = Nullav;
3127
3128     PL_rsfp = tryrsfp;
3129     SAVEHINTS();
3130     PL_hints = 0;
3131     SAVESPTR(PL_compiling.cop_warnings);
3132     if (PL_dowarn & G_WARN_ALL_ON)
3133         PL_compiling.cop_warnings = pWARN_ALL ;
3134     else if (PL_dowarn & G_WARN_ALL_OFF)
3135         PL_compiling.cop_warnings = pWARN_NONE ;
3136     else if (PL_taint_warn)
3137         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3138     else
3139         PL_compiling.cop_warnings = pWARN_STD ;
3140     SAVESPTR(PL_compiling.cop_io);
3141     PL_compiling.cop_io = Nullsv;
3142
3143     if (filter_sub || filter_child_proc) {
3144         SV *datasv = filter_add(run_user_filter, Nullsv);
3145         IoLINES(datasv) = filter_has_file;
3146         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3147         IoTOP_GV(datasv) = (GV *)filter_state;
3148         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3149     }
3150
3151     /* switch to eval mode */
3152     push_return(PL_op->op_next);
3153     PUSHBLOCK(cx, CXt_EVAL, SP);
3154     PUSHEVAL(cx, name, Nullgv);
3155
3156     SAVECOPLINE(&PL_compiling);
3157     CopLINE_set(&PL_compiling, 0);
3158
3159     PUTBACK;
3160
3161     /* Store and reset encoding. */
3162     encoding = PL_encoding;
3163     PL_encoding = Nullsv;
3164
3165     op = DOCATCH(doeval(gimme, NULL));
3166
3167     /* Restore encoding. */
3168     PL_encoding = encoding;
3169
3170     return op;
3171 }
3172
3173 PP(pp_dofile)
3174 {
3175     return pp_require();
3176 }
3177
3178 PP(pp_entereval)
3179 {
3180     dSP;
3181     register PERL_CONTEXT *cx;
3182     dPOPss;
3183     I32 gimme = GIMME_V, was = PL_sub_generation;
3184     char tbuf[TYPE_DIGITS(long) + 12];
3185     char *tmpbuf = tbuf;
3186     char *safestr;
3187     STRLEN len;
3188     OP *ret;
3189
3190     if (!SvPV(sv,len))
3191         RETPUSHUNDEF;
3192     TAINT_PROPER("eval");
3193
3194     ENTER;
3195     lex_start(sv);
3196     SAVETMPS;
3197
3198     /* switch to eval mode */
3199
3200     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3201         SV *sv = sv_newmortal();
3202         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3203                        (unsigned long)++PL_evalseq,
3204                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3205         tmpbuf = SvPVX(sv);
3206     }
3207     else
3208         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3209     SAVECOPFILE_FREE(&PL_compiling);
3210     CopFILE_set(&PL_compiling, tmpbuf+2);
3211     SAVECOPLINE(&PL_compiling);
3212     CopLINE_set(&PL_compiling, 1);
3213     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3214        deleting the eval's FILEGV from the stash before gv_check() runs
3215        (i.e. before run-time proper). To work around the coredump that
3216        ensues, we always turn GvMULTI_on for any globals that were
3217        introduced within evals. See force_ident(). GSAR 96-10-12 */
3218     safestr = savepv(tmpbuf);
3219     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3220     SAVEHINTS();
3221     PL_hints = PL_op->op_targ;
3222     SAVESPTR(PL_compiling.cop_warnings);
3223     if (specialWARN(PL_curcop->cop_warnings))
3224         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3225     else {
3226         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3227         SAVEFREESV(PL_compiling.cop_warnings);
3228     }
3229     SAVESPTR(PL_compiling.cop_io);
3230     if (specialCopIO(PL_curcop->cop_io))
3231         PL_compiling.cop_io = PL_curcop->cop_io;
3232     else {
3233         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3234         SAVEFREESV(PL_compiling.cop_io);
3235     }
3236
3237     push_return(PL_op->op_next);
3238     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3239     PUSHEVAL(cx, 0, Nullgv);
3240
3241     /* prepare to compile string */
3242
3243     if (PERLDB_LINE && PL_curstash != PL_debstash)
3244         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3245     PUTBACK;
3246     ret = doeval(gimme, NULL);
3247     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3248         && ret != PL_op->op_next) {     /* Successive compilation. */
3249         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3250     }
3251     return DOCATCH(ret);
3252 }
3253
3254 PP(pp_leaveeval)
3255 {
3256     dSP;
3257     register SV **mark;
3258     SV **newsp;
3259     PMOP *newpm;
3260     I32 gimme;
3261     register PERL_CONTEXT *cx;
3262     OP *retop;
3263     U8 save_flags = PL_op -> op_flags;
3264     I32 optype;
3265
3266     POPBLOCK(cx,newpm);
3267     POPEVAL(cx);
3268     retop = pop_return();
3269
3270     TAINT_NOT;
3271     if (gimme == G_VOID)
3272         MARK = newsp;
3273     else if (gimme == G_SCALAR) {
3274         MARK = newsp + 1;
3275         if (MARK <= SP) {
3276             if (SvFLAGS(TOPs) & SVs_TEMP)
3277                 *MARK = TOPs;
3278             else
3279                 *MARK = sv_mortalcopy(TOPs);
3280         }
3281         else {
3282             MEXTEND(mark,0);
3283             *MARK = &PL_sv_undef;
3284         }
3285         SP = MARK;
3286     }
3287     else {
3288         /* in case LEAVE wipes old return values */
3289         for (mark = newsp + 1; mark <= SP; mark++) {
3290             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3291                 *mark = sv_mortalcopy(*mark);
3292                 TAINT_NOT;      /* Each item is independent */
3293             }
3294         }
3295     }
3296     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3297
3298 #ifdef DEBUGGING
3299     assert(CvDEPTH(PL_compcv) == 1);
3300 #endif
3301     CvDEPTH(PL_compcv) = 0;
3302     lex_end();
3303
3304     if (optype == OP_REQUIRE &&
3305         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3306     {
3307         /* Unassume the success we assumed earlier. */
3308         SV *nsv = cx->blk_eval.old_namesv;
3309         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3310         retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3311         /* die_where() did LEAVE, or we won't be here */
3312     }
3313     else {
3314         LEAVE;
3315         if (!(save_flags & OPf_SPECIAL))
3316             sv_setpv(ERRSV,"");
3317     }
3318
3319     RETURNOP(retop);
3320 }
3321
3322 PP(pp_entertry)
3323 {
3324     dSP;
3325     register PERL_CONTEXT *cx;
3326     I32 gimme = GIMME_V;
3327
3328     ENTER;
3329     SAVETMPS;
3330
3331     push_return(cLOGOP->op_other->op_next);
3332     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3333     PUSHEVAL(cx, 0, 0);
3334
3335     PL_in_eval = EVAL_INEVAL;
3336     sv_setpv(ERRSV,"");
3337     PUTBACK;
3338     return DOCATCH(PL_op->op_next);
3339 }
3340
3341 PP(pp_leavetry)
3342 {
3343     dSP;
3344     register SV **mark;
3345     SV **newsp;
3346     PMOP *newpm;
3347     OP* retop;
3348     I32 gimme;
3349     register PERL_CONTEXT *cx;
3350     I32 optype;
3351
3352     POPBLOCK(cx,newpm);
3353     POPEVAL(cx);
3354     retop = pop_return();
3355
3356     TAINT_NOT;
3357     if (gimme == G_VOID)
3358         SP = newsp;
3359     else if (gimme == G_SCALAR) {
3360         MARK = newsp + 1;
3361         if (MARK <= SP) {
3362             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3363                 *MARK = TOPs;
3364             else
3365                 *MARK = sv_mortalcopy(TOPs);
3366         }
3367         else {
3368             MEXTEND(mark,0);
3369             *MARK = &PL_sv_undef;
3370         }
3371         SP = MARK;
3372     }
3373     else {
3374         /* in case LEAVE wipes old return values */
3375         for (mark = newsp + 1; mark <= SP; mark++) {
3376             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3377                 *mark = sv_mortalcopy(*mark);
3378                 TAINT_NOT;      /* Each item is independent */
3379             }
3380         }
3381     }
3382     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3383
3384     LEAVE;
3385     sv_setpv(ERRSV,"");
3386     RETURNOP(retop);
3387 }
3388
3389 STATIC void
3390 S_doparseform(pTHX_ SV *sv)
3391 {
3392     STRLEN len;
3393     register char *s = SvPV_force(sv, len);
3394     register char *send = s + len;
3395     register char *base = Nullch;
3396     register I32 skipspaces = 0;
3397     bool noblank   = FALSE;
3398     bool repeat    = FALSE;
3399     bool postspace = FALSE;
3400     U16 *fops;
3401     register U16 *fpc;
3402     U16 *linepc = 0;
3403     register I32 arg;
3404     bool ischop;
3405
3406     if (len == 0)
3407         Perl_croak(aTHX_ "Null picture in formline");
3408
3409     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3410     fpc = fops;
3411
3412     if (s < send) {
3413         linepc = fpc;
3414         *fpc++ = FF_LINEMARK;
3415         noblank = repeat = FALSE;
3416         base = s;
3417     }
3418
3419     while (s <= send) {
3420         switch (*s++) {
3421         default:
3422             skipspaces = 0;
3423             continue;
3424
3425         case '~':
3426             if (*s == '~') {
3427                 repeat = TRUE;
3428                 *s = ' ';
3429             }
3430             noblank = TRUE;
3431             s[-1] = ' ';
3432             /* FALL THROUGH */
3433         case ' ': case '\t':
3434             skipspaces++;
3435             continue;
3436
3437         case '\n': case 0:
3438             arg = s - base;
3439             skipspaces++;
3440             arg -= skipspaces;
3441             if (arg) {
3442                 if (postspace)
3443                     *fpc++ = FF_SPACE;
3444                 *fpc++ = FF_LITERAL;
3445                 *fpc++ = (U16)arg;
3446             }
3447             postspace = FALSE;
3448             if (s <= send)
3449                 skipspaces--;
3450             if (skipspaces) {
3451                 *fpc++ = FF_SKIP;
3452                 *fpc++ = (U16)skipspaces;
3453             }
3454             skipspaces = 0;
3455             if (s <= send)
3456                 *fpc++ = FF_NEWLINE;
3457             if (noblank) {
3458                 *fpc++ = FF_BLANK;
3459                 if (repeat)
3460                     arg = fpc - linepc + 1;
3461                 else
3462                     arg = 0;
3463                 *fpc++ = (U16)arg;
3464             }
3465             if (s < send) {
3466                 linepc = fpc;
3467                 *fpc++ = FF_LINEMARK;
3468                 noblank = repeat = FALSE;
3469                 base = s;
3470             }
3471             else
3472                 s++;
3473             continue;
3474
3475         case '@':
3476         case '^':
3477             ischop = s[-1] == '^';
3478
3479             if (postspace) {
3480                 *fpc++ = FF_SPACE;
3481                 postspace = FALSE;
3482             }
3483             arg = (s - base) - 1;
3484             if (arg) {
3485                 *fpc++ = FF_LITERAL;
3486                 *fpc++ = (U16)arg;
3487             }
3488
3489             base = s - 1;
3490             *fpc++ = FF_FETCH;
3491             if (*s == '*') {
3492                 s++;
3493                 *fpc++ = 0;
3494                 *fpc++ = FF_LINEGLOB;
3495             }
3496             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3497                 arg = ischop ? 512 : 0;
3498                 base = s - 1;
3499                 while (*s == '#')
3500                     s++;
3501                 if (*s == '.') {
3502                     char *f;
3503                     s++;
3504                     f = s;
3505                     while (*s == '#')
3506                         s++;
3507                     arg |= 256 + (s - f);
3508                 }
3509                 *fpc++ = s - base;              /* fieldsize for FETCH */
3510                 *fpc++ = FF_DECIMAL;
3511                 *fpc++ = (U16)arg;
3512             }
3513             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3514                 arg = ischop ? 512 : 0;
3515                 base = s - 1;
3516                 s++;                                /* skip the '0' first */
3517                 while (*s == '#')
3518                     s++;
3519                 if (*s == '.') {
3520                     char *f;
3521                     s++;
3522                     f = s;
3523                     while (*s == '#')
3524                         s++;
3525                     arg |= 256 + (s - f);
3526                 }
3527                 *fpc++ = s - base;                /* fieldsize for FETCH */
3528                 *fpc++ = FF_0DECIMAL;
3529                 *fpc++ = (U16)arg;
3530             }
3531             else {
3532                 I32 prespace = 0;
3533                 bool ismore = FALSE;
3534
3535                 if (*s == '>') {
3536                     while (*++s == '>') ;
3537                     prespace = FF_SPACE;
3538                 }
3539                 else if (*s == '|') {
3540                     while (*++s == '|') ;
3541                     prespace = FF_HALFSPACE;
3542                     postspace = TRUE;
3543                 }
3544                 else {
3545                     if (*s == '<')
3546                         while (*++s == '<') ;
3547                     postspace = TRUE;
3548                 }
3549                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3550                     s += 3;
3551                     ismore = TRUE;
3552                 }
3553                 *fpc++ = s - base;              /* fieldsize for FETCH */
3554
3555                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3556
3557                 if (prespace)
3558                     *fpc++ = (U16)prespace;
3559                 *fpc++ = FF_ITEM;
3560                 if (ismore)
3561                     *fpc++ = FF_MORE;
3562                 if (ischop)
3563                     *fpc++ = FF_CHOP;
3564             }
3565             base = s;
3566             skipspaces = 0;
3567             continue;
3568         }
3569     }
3570     *fpc++ = FF_END;
3571
3572     arg = fpc - fops;
3573     { /* need to jump to the next word */
3574         int z;
3575         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3576         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3577         s = SvPVX(sv) + SvCUR(sv) + z;
3578     }
3579     Copy(fops, s, arg, U16);
3580     Safefree(fops);
3581     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3582     SvCOMPILED_on(sv);
3583 }
3584
3585 static I32
3586 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3587 {
3588     SV *datasv = FILTER_DATA(idx);
3589     int filter_has_file = IoLINES(datasv);
3590     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3591     SV *filter_state = (SV *)IoTOP_GV(datasv);
3592     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3593     int len = 0;
3594
3595     /* I was having segfault trouble under Linux 2.2.5 after a
3596        parse error occured.  (Had to hack around it with a test
3597        for PL_error_count == 0.)  Solaris doesn't segfault --
3598        not sure where the trouble is yet.  XXX */
3599
3600     if (filter_has_file) {
3601         len = FILTER_READ(idx+1, buf_sv, maxlen);
3602     }
3603
3604     if (filter_sub && len >= 0) {
3605         dSP;
3606         int count;
3607
3608         ENTER;
3609         SAVE_DEFSV;
3610         SAVETMPS;
3611         EXTEND(SP, 2);
3612
3613         DEFSV = buf_sv;
3614         PUSHMARK(SP);
3615         PUSHs(sv_2mortal(newSViv(maxlen)));
3616         if (filter_state) {
3617             PUSHs(filter_state);
3618         }
3619         PUTBACK;
3620         count = call_sv(filter_sub, G_SCALAR);
3621         SPAGAIN;
3622
3623         if (count > 0) {
3624             SV *out = POPs;
3625             if (SvOK(out)) {
3626                 len = SvIV(out);
3627             }
3628         }
3629
3630         PUTBACK;
3631         FREETMPS;
3632         LEAVE;
3633     }
3634
3635     if (len <= 0) {
3636         IoLINES(datasv) = 0;
3637         if (filter_child_proc) {
3638             SvREFCNT_dec(filter_child_proc);
3639             IoFMT_GV(datasv) = Nullgv;
3640         }
3641         if (filter_state) {
3642             SvREFCNT_dec(filter_state);
3643             IoTOP_GV(datasv) = Nullgv;
3644         }
3645         if (filter_sub) {
3646             SvREFCNT_dec(filter_sub);
3647             IoBOTTOM_GV(datasv) = Nullgv;
3648         }
3649         filter_del(run_user_filter);
3650     }
3651
3652     return len;
3653 }
3654
3655 /* perhaps someone can come up with a better name for
3656    this?  it is not really "absolute", per se ... */
3657 static bool
3658 S_path_is_absolute(pTHX_ char *name)
3659 {
3660     if (PERL_FILE_IS_ABSOLUTE(name)
3661 #ifdef MACOS_TRADITIONAL
3662         || (*name == ':'))
3663 #else
3664         || (*name == '.' && (name[1] == '/' ||
3665                              (name[1] == '.' && name[2] == '/'))))
3666 #endif
3667     {
3668         return TRUE;
3669     }
3670     else
3671         return FALSE;
3672 }