pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (c) 1991-2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * Now far ahead the Road has gone,
  12  * And I must follow, if I can,
  13  * Pursuing it with eager feet,
  14  * Until it joins some larger way
  15  * Where many paths and errands meet.
  16  * And whither then?  I cannot say.
  17  */
  18
  19 #include "EXTERN.h"
  20 #define PERL_IN_PP_CTL_C
  21 #include "perl.h"
  22
  23 #ifndef WORD_ALIGN
  24 #define WORD_ALIGN sizeof(U16)
  25 #endif
  26
  27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  28
  29 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
  30
  31 PP(pp_wantarray)
  32 {
  33     dSP;
  34     I32 cxix;
  35     EXTEND(SP, 1);
  36
  37     cxix = dopoptosub(cxstack_ix);
  38     if (cxix < 0)
  39         RETPUSHUNDEF;
  40
  41     switch (cxstack[cxix].blk_gimme) {
  42     case G_ARRAY:
  43         RETPUSHYES;
  44     case G_SCALAR:
  45         RETPUSHNO;
  46     default:
  47         RETPUSHUNDEF;
  48     }
  49 }
  50
  51 PP(pp_regcmaybe)
  52 {
  53     return NORMAL;
  54 }
  55
  56 PP(pp_regcreset)
  57 {
  58     /* XXXX Should store the old value to allow for tie/overload - and
  59        restore in regcomp, where marked with XXXX. */
  60     PL_reginterp_cnt = 0;
  61     return NORMAL;
  62 }
  63
  64 PP(pp_regcomp)
  65 {
  66     dSP;
  67     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  68     register char *t;
  69     SV *tmpstr;
  70     STRLEN len;
  71     MAGIC *mg = Null(MAGIC*);
  72
  73     tmpstr = POPs;
  74
  75     /* prevent recompiling under /o and ithreads. */
  76 #if defined(USE_ITHREADS) || defined(USE_5005THREADS)
  77     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
  78          RETURN;
  79 #endif
  80
  81     if (SvROK(tmpstr)) {
  82         SV *sv = SvRV(tmpstr);
  83         if(SvMAGICAL(sv))
  84             mg = mg_find(sv, PERL_MAGIC_qr);
  85     }
  86     if (mg) {
  87         regexp *re = (regexp *)mg->mg_obj;
  88         ReREFCNT_dec(PM_GETRE(pm));
  89         PM_SETRE(pm, ReREFCNT_inc(re));
  90     }
  91     else {
  92         t = SvPV(tmpstr, len);
  93
  94         /* Check against the last compiled regexp. */
  95         if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
  96             PM_GETRE(pm)->prelen != (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) && !defined(USE_5005THREADS)
 142         /* XXX can't change the optree at runtime either */
 143         cLOGOP->op_first->op_next = PL_op->op_next;
 144 #endif
 145     }
 146     RETURN;
 147 }
 148
 149 PP(pp_substcont)
 150 {
 151     dSP;
 152     register PMOP *pm = (PMOP*) cLOGOP->op_other;
 153     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 154     register SV *dstr = cx->sb_dstr;
 155     register char *s = cx->sb_s;
 156     register char *m = cx->sb_m;
 157     char *orig = cx->sb_orig;
 158     register REGEXP *rx = cx->sb_rx;
 159
 160     rxres_restore(&cx->sb_rxres, rx);
 161     PL_reg_match_utf8 = SvUTF8(cx->sb_targ) ? 1 : 0;
 162
 163     if (cx->sb_iters++) {
 164         I32 saviters = cx->sb_iters;
 165         if (cx->sb_iters > cx->sb_maxiters)
 166             DIE(aTHX_ "Substitution loop");
 167
 168         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 169             cx->sb_rxtainted |= 2;
 170         sv_catsv(dstr, POPs);
 171
 172         /* Are we done */
 173         if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
 174                                      s == m, cx->sb_targ, NULL,
 175                                      ((cx->sb_rflags & REXEC_COPY_STR)
 176                                       ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 177                                       : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 178         {
 179             SV *targ = cx->sb_targ;
 180
 181             sv_catpvn(dstr, s, cx->sb_strend - s);
 182             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 183
 184             (void)SvOOK_off(targ);
 185             Safefree(SvPVX(targ));
 186             SvPVX(targ) = SvPVX(dstr);
 187             SvCUR_set(targ, SvCUR(dstr));
 188             SvLEN_set(targ, SvLEN(dstr));
 189             if (DO_UTF8(dstr))
 190                 SvUTF8_on(targ);
 191             SvPVX(dstr) = 0;
 192             sv_free(dstr);
 193
 194             TAINT_IF(cx->sb_rxtainted & 1);
 195             PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
 196
 197             (void)SvPOK_only_UTF8(targ);
 198             TAINT_IF(cx->sb_rxtainted);
 199             SvSETMAGIC(targ);
 200             SvTAINT(targ);
 201
 202             LEAVE_SCOPE(cx->sb_oldsave);
 203             POPSUBST(cx);
 204             RETURNOP(pm->op_next);
 205         }
 206         cx->sb_iters = saviters;
 207     }
 208     if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
 209         m = s;
 210         s = orig;
 211         cx->sb_orig = orig = rx->subbeg;
 212         s = orig + (m - s);
 213         cx->sb_strend = s + (cx->sb_strend - m);
 214     }
 215     cx->sb_m = m = rx->startp[0] + orig;
 216     if (m > s)
 217         sv_catpvn(dstr, s, m-s);
 218     cx->sb_s = rx->endp[0] + orig;
 219     { /* Update the pos() information. */
 220         SV *sv = cx->sb_targ;
 221         MAGIC *mg;
 222         I32 i;
 223         if (SvTYPE(sv) < SVt_PVMG)
 224             (void)SvUPGRADE(sv, SVt_PVMG);
 225         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 226             sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
 227             mg = mg_find(sv, PERL_MAGIC_regex_global);
 228         }
 229         i = m - orig;
 230         if (DO_UTF8(sv))
 231             sv_pos_b2u(sv, &i);
 232         mg->mg_len = i;
 233     }
 234     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 235     rxres_save(&cx->sb_rxres, rx);
 236     RETURNOP(pm->op_pmreplstart);
 237 }
 238
 239 void
 240 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 241 {
 242     UV *p = (UV*)*rsp;
 243     U32 i;
 244
 245     if (!p || p[1] < rx->nparens) {
 246         i = 6 + rx->nparens * 2;
 247         if (!p)
 248             New(501, p, i, UV);
 249         else
 250             Renew(p, i, UV);
 251         *rsp = (void*)p;
 252     }
 253
 254     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
 255     RX_MATCH_COPIED_off(rx);
 256
 257     *p++ = rx->nparens;
 258
 259     *p++ = PTR2UV(rx->subbeg);
 260     *p++ = (UV)rx->sublen;
 261     for (i = 0; i <= rx->nparens; ++i) {
 262         *p++ = (UV)rx->startp[i];
 263         *p++ = (UV)rx->endp[i];
 264     }
 265 }
 266
 267 void
 268 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 269 {
 270     UV *p = (UV*)*rsp;
 271     U32 i;
 272
 273     if (RX_MATCH_COPIED(rx))
 274         Safefree(rx->subbeg);
 275     RX_MATCH_COPIED_set(rx, *p);
 276     *p++ = 0;
 277
 278     rx->nparens = *p++;
 279
 280     rx->subbeg = INT2PTR(char*,*p++);
 281     rx->sublen = (I32)(*p++);
 282     for (i = 0; i <= rx->nparens; ++i) {
 283         rx->startp[i] = (I32)(*p++);
 284         rx->endp[i] = (I32)(*p++);
 285     }
 286 }
 287
 288 void
 289 Perl_rxres_free(pTHX_ void **rsp)
 290 {
 291     UV *p = (UV*)*rsp;
 292
 293     if (p) {
 294         Safefree(INT2PTR(char*,*p));
 295         Safefree(p);
 296         *rsp = Null(void*);
 297     }
 298 }
 299
 300 PP(pp_formline)
 301 {
 302     dSP; dMARK; dORIGMARK;
 303     register SV *tmpForm = *++MARK;
 304     register U16 *fpc;
 305     register char *t;
 306     register char *f;
 307     register char *s;
 308     register char *send;
 309     register I32 arg;
 310     register SV *sv = Nullsv;
 311     char *item = Nullch;
 312     I32 itemsize  = 0;
 313     I32 fieldsize = 0;
 314     I32 lines = 0;
 315     bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
 316     char *chophere = Nullch;
 317     char *linemark = Nullch;
 318     NV value;
 319     bool gotsome = FALSE;
 320     STRLEN len;
 321     STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
 322     bool item_is_utf = FALSE;
 323
 324     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 325         if (SvREADONLY(tmpForm)) {
 326             SvREADONLY_off(tmpForm);
 327             doparseform(tmpForm);
 328             SvREADONLY_on(tmpForm);
 329         }
 330         else
 331             doparseform(tmpForm);
 332     }
 333
 334     SvPV_force(PL_formtarget, len);
 335     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 336     t += len;
 337     f = SvPV(tmpForm, len);
 338     /* need to jump to the next word */
 339     s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
 340
 341     fpc = (U16*)s;
 342
 343     for (;;) {
 344         DEBUG_f( {
 345             char *name = "???";
 346             arg = -1;
 347             switch (*fpc) {
 348             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 349             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 350             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 351             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 352             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 353
 354             case FF_CHECKNL:    name = "CHECKNL";       break;
 355             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 356             case FF_SPACE:      name = "SPACE";         break;
 357             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 358             case FF_ITEM:       name = "ITEM";          break;
 359             case FF_CHOP:       name = "CHOP";          break;
 360             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 361             case FF_NEWLINE:    name = "NEWLINE";       break;
 362             case FF_MORE:       name = "MORE";          break;
 363             case FF_LINEMARK:   name = "LINEMARK";      break;
 364             case FF_END:        name = "END";           break;
 365             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 366             }
 367             if (arg >= 0)
 368                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 369             else
 370                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 371         } );
 372         switch (*fpc++) {
 373         case FF_LINEMARK:
 374             linemark = t;
 375             lines++;
 376             gotsome = FALSE;
 377             break;
 378
 379         case FF_LITERAL:
 380             arg = *fpc++;
 381             while (arg--)
 382                 *t++ = *f++;
 383             break;
 384
 385         case FF_SKIP:
 386             f += *fpc++;
 387             break;
 388
 389         case FF_FETCH:
 390             arg = *fpc++;
 391             f += arg;
 392             fieldsize = arg;
 393
 394             if (MARK < SP)
 395                 sv = *++MARK;
 396             else {
 397                 sv = &PL_sv_no;
 398                 if (ckWARN(WARN_SYNTAX))
 399                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 400             }
 401             break;
 402
 403         case FF_CHECKNL:
 404             item = s = SvPV(sv, len);
 405             itemsize = len;
 406             if (DO_UTF8(sv)) {
 407                 itemsize = sv_len_utf8(sv);
 408                 if (itemsize != (I32)len) {
 409                     I32 itembytes;
 410                     if (itemsize > fieldsize) {
 411                         itemsize = fieldsize;
 412                         itembytes = itemsize;
 413                         sv_pos_u2b(sv, &itembytes, 0);
 414                     }
 415                     else
 416                         itembytes = len;
 417                     send = chophere = s + itembytes;
 418                     while (s < send) {
 419                         if (*s & ~31)
 420                             gotsome = TRUE;
 421                         else if (*s == '\n')
 422                             break;
 423                         s++;
 424                     }
 425                     item_is_utf = TRUE;
 426                     itemsize = s - item;
 427                     sv_pos_b2u(sv, &itemsize);
 428                     break;
 429                 }
 430             }
 431             item_is_utf = FALSE;
 432             if (itemsize > fieldsize)
 433                 itemsize = fieldsize;
 434             send = chophere = s + itemsize;
 435             while (s < send) {
 436                 if (*s & ~31)
 437                     gotsome = TRUE;
 438                 else if (*s == '\n')
 439                     break;
 440                 s++;
 441             }
 442             itemsize = s - item;
 443             break;
 444
 445         case FF_CHECKCHOP:
 446             item = s = SvPV(sv, len);
 447             itemsize = len;
 448             if (DO_UTF8(sv)) {
 449                 itemsize = sv_len_utf8(sv);
 450                 if (itemsize != (I32)len) {
 451                     I32 itembytes;
 452                     if (itemsize <= fieldsize) {
 453                         send = chophere = s + itemsize;
 454                         while (s < send) {
 455                             if (*s == '\r') {
 456                                 itemsize = s - item;
 457                                 break;
 458                             }
 459                             if (*s++ & ~31)
 460                                 gotsome = TRUE;
 461                         }
 462                     }
 463                     else {
 464                         itemsize = fieldsize;
 465                         itembytes = itemsize;
 466                         sv_pos_u2b(sv, &itembytes, 0);
 467                         send = chophere = s + itembytes;
 468                         while (s < send || (s == send && isSPACE(*s))) {
 469                             if (isSPACE(*s)) {
 470                                 if (chopspace)
 471                                     chophere = s;
 472                                 if (*s == '\r')
 473                                     break;
 474                             }
 475                             else {
 476                                 if (*s & ~31)
 477                                     gotsome = TRUE;
 478                                 if (strchr(PL_chopset, *s))
 479                                     chophere = s + 1;
 480                             }
 481                             s++;
 482                         }
 483                         itemsize = chophere - item;
 484                         sv_pos_b2u(sv, &itemsize);
 485                     }
 486                     item_is_utf = TRUE;
 487                     break;
 488                 }
 489             }
 490             item_is_utf = FALSE;
 491             if (itemsize <= fieldsize) {
 492                 send = chophere = s + itemsize;
 493                 while (s < send) {
 494                     if (*s == '\r') {
 495                         itemsize = s - item;
 496                         break;
 497                     }
 498                     if (*s++ & ~31)
 499                         gotsome = TRUE;
 500                 }
 501             }
 502             else {
 503                 itemsize = fieldsize;
 504                 send = chophere = s + itemsize;
 505                 while (s < send || (s == send && isSPACE(*s))) {
 506                     if (isSPACE(*s)) {
 507                         if (chopspace)
 508                             chophere = s;
 509                         if (*s == '\r')
 510                             break;
 511                     }
 512                     else {
 513                         if (*s & ~31)
 514                             gotsome = TRUE;
 515                         if (strchr(PL_chopset, *s))
 516                             chophere = s + 1;
 517                     }
 518                     s++;
 519                 }
 520                 itemsize = chophere - item;
 521             }
 522             break;
 523
 524         case FF_SPACE:
 525             arg = fieldsize - itemsize;
 526             if (arg) {
 527                 fieldsize -= arg;
 528                 while (arg-- > 0)
 529                     *t++ = ' ';
 530             }
 531             break;
 532
 533         case FF_HALFSPACE:
 534             arg = fieldsize - itemsize;
 535             if (arg) {
 536                 arg /= 2;
 537                 fieldsize -= arg;
 538                 while (arg-- > 0)
 539                     *t++ = ' ';
 540             }
 541             break;
 542
 543         case FF_ITEM:
 544             arg = itemsize;
 545             s = item;
 546             if (item_is_utf) {
 547                 while (arg--) {
 548                     if (UTF8_IS_CONTINUED(*s)) {
 549                         STRLEN skip = UTF8SKIP(s);
 550                         switch (skip) {
 551                         default:
 552                             Move(s,t,skip,char);
 553                             s += skip;
 554                             t += skip;
 555                             break;
 556                         case 7: *t++ = *s++;
 557                         case 6: *t++ = *s++;
 558                         case 5: *t++ = *s++;
 559                         case 4: *t++ = *s++;
 560                         case 3: *t++ = *s++;
 561                         case 2: *t++ = *s++;
 562                         case 1: *t++ = *s++;
 563                         }
 564                     }
 565                     else {
 566                         if ( !((*t++ = *s++) & ~31) )
 567                             t[-1] = ' ';
 568                     }
 569                 }
 570                 break;
 571             }
 572             while (arg--) {
 573 #ifdef EBCDIC
 574                 int ch = *t++ = *s++;
 575                 if (iscntrl(ch))
 576 #else
 577                 if ( !((*t++ = *s++) & ~31) )
 578 #endif
 579                     t[-1] = ' ';
 580             }
 581             break;
 582
 583         case FF_CHOP:
 584             s = chophere;
 585             if (chopspace) {
 586                 while (*s && isSPACE(*s))
 587                     s++;
 588             }
 589             sv_chop(sv,s);
 590             break;
 591
 592         case FF_LINEGLOB:
 593             item = s = SvPV(sv, len);
 594             itemsize = len;
 595             item_is_utf = FALSE;                /* XXX is this correct? */
 596             if (itemsize) {
 597                 gotsome = TRUE;
 598                 send = s + itemsize;
 599                 while (s < send) {
 600                     if (*s++ == '\n') {
 601                         if (s == send)
 602                             itemsize--;
 603                         else
 604                             lines++;
 605                     }
 606                 }
 607                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 608                 sv_catpvn(PL_formtarget, item, itemsize);
 609                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 610                 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 611             }
 612             break;
 613
 614         case FF_DECIMAL:
 615             /* If the field is marked with ^ and the value is undefined,
 616                blank it out. */
 617             arg = *fpc++;
 618             if ((arg & 512) && !SvOK(sv)) {
 619                 arg = fieldsize;
 620                 while (arg--)
 621                     *t++ = ' ';
 622                 break;
 623             }
 624             gotsome = TRUE;
 625             value = SvNV(sv);
 626             /* Formats aren't yet marked for locales, so assume "yes". */
 627             {
 628                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 629 #if defined(USE_LONG_DOUBLE)
 630                 if (arg & 256) {
 631                     sprintf(t, "%#*.*" PERL_PRIfldbl,
 632                             (int) fieldsize, (int) arg & 255, value);
 633                 } else {
 634                     sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
 635                 }
 636 #else
 637                 if (arg & 256) {
 638                     sprintf(t, "%#*.*f",
 639                             (int) fieldsize, (int) arg & 255, value);
 640                 } else {
 641                     sprintf(t, "%*.0f",
 642                             (int) fieldsize, value);
 643                 }
 644 #endif
 645                 RESTORE_NUMERIC_STANDARD();
 646             }
 647             t += fieldsize;
 648             break;
 649
 650         case FF_0DECIMAL:
 651             /* If the field is marked with ^ and the value is undefined,
 652                blank it out. */
 653             arg = *fpc++;
 654             if ((arg & 512) && !SvOK(sv)) {
 655                 arg = fieldsize;
 656                 while (arg--)
 657                     *t++ = ' ';
 658                 break;
 659             }
 660             gotsome = TRUE;
 661             value = SvNV(sv);
 662             /* Formats aren't yet marked for locales, so assume "yes". */
 663             {
 664                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 665 #if defined(USE_LONG_DOUBLE)
 666                 if (arg & 256) {
 667                     sprintf(t, "%#0*.*" PERL_PRIfldbl,
 668                             (int) fieldsize, (int) arg & 255, value);
 669 /* is this legal? I don't have long doubles */
 670                 } else {
 671                     sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
 672                 }
 673 #else
 674                 if (arg & 256) {
 675                     sprintf(t, "%#0*.*f",
 676                             (int) fieldsize, (int) arg & 255, value);
 677                 } else {
 678                     sprintf(t, "%0*.0f",
 679                             (int) fieldsize, value);
 680                 }
 681 #endif
 682                 RESTORE_NUMERIC_STANDARD();
 683             }
 684             t += fieldsize;
 685             break;
 686
 687         case FF_NEWLINE:
 688             f++;
 689             while (t-- > linemark && *t == ' ') ;
 690             t++;
 691             *t++ = '\n';
 692             break;
 693
 694         case FF_BLANK:
 695             arg = *fpc++;
 696             if (gotsome) {
 697                 if (arg) {              /* repeat until fields exhausted? */
 698                     *t = '\0';
 699                     SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 700                     lines += FmLINES(PL_formtarget);
 701                     if (lines == 200) {
 702                         arg = t - linemark;
 703                         if (strnEQ(linemark, linemark - arg, arg))
 704                             DIE(aTHX_ "Runaway format");
 705                     }
 706                     FmLINES(PL_formtarget) = lines;
 707                     SP = ORIGMARK;
 708                     RETURNOP(cLISTOP->op_first);
 709                 }
 710             }
 711             else {
 712                 t = linemark;
 713                 lines--;
 714             }
 715             break;
 716
 717         case FF_MORE:
 718             s = chophere;
 719             send = item + len;
 720             if (chopspace) {
 721                 while (*s && isSPACE(*s) && s < send)
 722                     s++;
 723             }
 724             if (s < send) {
 725                 arg = fieldsize - itemsize;
 726                 if (arg) {
 727                     fieldsize -= arg;
 728                     while (arg-- > 0)
 729                         *t++ = ' ';
 730                 }
 731                 s = t - 3;
 732                 if (strnEQ(s,"   ",3)) {
 733                     while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
 734                         s--;
 735                 }
 736                 *s++ = '.';
 737                 *s++ = '.';
 738                 *s++ = '.';
 739             }
 740             break;
 741
 742         case FF_END:
 743             *t = '\0';
 744             SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 745             FmLINES(PL_formtarget) += lines;
 746             SP = ORIGMARK;
 747             RETPUSHYES;
 748         }
 749     }
 750 }
 751
 752 PP(pp_grepstart)
 753 {
 754     dSP;
 755     SV *src;
 756
 757     if (PL_stack_base + *PL_markstack_ptr == SP) {
 758         (void)POPMARK;
 759         if (GIMME_V == G_SCALAR)
 760             XPUSHs(sv_2mortal(newSViv(0)));
 761         RETURNOP(PL_op->op_next->op_next);
 762     }
 763     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
 764     pp_pushmark();                              /* push dst */
 765     pp_pushmark();                              /* push src */
 766     ENTER;                                      /* enter outer scope */
 767
 768     SAVETMPS;
 769     /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
 770     SAVESPTR(DEFSV);
 771     ENTER;                                      /* enter inner scope */
 772     SAVEVPTR(PL_curpm);
 773
 774     src = PL_stack_base[*PL_markstack_ptr];
 775     SvTEMP_off(src);
 776     DEFSV = src;
 777
 778     PUTBACK;
 779     if (PL_op->op_type == OP_MAPSTART)
 780         pp_pushmark();                  /* push top */
 781     return ((LOGOP*)PL_op->op_next)->op_other;
 782 }
 783
 784 PP(pp_mapstart)
 785 {
 786     DIE(aTHX_ "panic: mapstart");       /* uses grepstart */
 787 }
 788
 789 PP(pp_mapwhile)
 790 {
 791     dSP;
 792     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
 793     I32 count;
 794     I32 shift;
 795     SV** src;
 796     SV** dst;
 797
 798     /* first, move source pointer to the next item in the source list */
 799     ++PL_markstack_ptr[-1];
 800
 801     /* if there are new items, push them into the destination list */
 802     if (items) {
 803         /* might need to make room back there first */
 804         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
 805             /* XXX this implementation is very pessimal because the stack
 806              * is repeatedly extended for every set of items.  Is possible
 807              * to do this without any stack extension or copying at all
 808              * by maintaining a separate list over which the map iterates
 809              * (like foreach does). --gsar */
 810
 811             /* everything in the stack after the destination list moves
 812              * towards the end the stack by the amount of room needed */
 813             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
 814
 815             /* items to shift up (accounting for the moved source pointer) */
 816             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
 817
 818             /* This optimization is by Ben Tilly and it does
 819              * things differently from what Sarathy (gsar)
 820              * is describing.  The downside of this optimization is
 821              * that leaves "holes" (uninitialized and hopefully unused areas)
 822              * to the Perl stack, but on the other hand this
 823              * shouldn't be a problem.  If Sarathy's idea gets
 824              * implemented, this optimization should become
 825              * irrelevant.  --jhi */
 826             if (shift < count)
 827                 shift = count; /* Avoid shifting too often --Ben Tilly */
 828
 829             EXTEND(SP,shift);
 830             src = SP;
 831             dst = (SP += shift);
 832             PL_markstack_ptr[-1] += shift;
 833             *PL_markstack_ptr += shift;
 834             while (count--)
 835                 *dst-- = *src--;
 836         }
 837         /* copy the new items down to the destination list */
 838         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
 839         while (items-- > 0)
 840             *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
 841     }
 842     LEAVE;                                      /* exit inner scope */
 843
 844     /* All done yet? */
 845     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
 846         I32 gimme = GIMME_V;
 847
 848         (void)POPMARK;                          /* pop top */
 849         LEAVE;                                  /* exit outer scope */
 850         (void)POPMARK;                          /* pop src */
 851         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
 852         (void)POPMARK;                          /* pop dst */
 853         SP = PL_stack_base + POPMARK;           /* pop original mark */
 854         if (gimme == G_SCALAR) {
 855             dTARGET;
 856             XPUSHi(items);
 857         }
 858         else if (gimme == G_ARRAY)
 859             SP += items;
 860         RETURN;
 861     }
 862     else {
 863         SV *src;
 864
 865         ENTER;                                  /* enter inner scope */
 866         SAVEVPTR(PL_curpm);
 867
 868         /* set $_ to the new source item */
 869         src = PL_stack_base[PL_markstack_ptr[-1]];
 870         SvTEMP_off(src);
 871         DEFSV = src;
 872
 873         RETURNOP(cLOGOP->op_other);
 874     }
 875 }
 876
 877 /* Range stuff. */
 878
 879 PP(pp_range)
 880 {
 881     if (GIMME == G_ARRAY)
 882         return NORMAL;
 883     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
 884         return cLOGOP->op_other;
 885     else
 886         return NORMAL;
 887 }
 888
 889 PP(pp_flip)
 890 {
 891     dSP;
 892
 893     if (GIMME == G_ARRAY) {
 894         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
 895     }
 896     else {
 897         dTOPss;
 898         SV *targ = PAD_SV(PL_op->op_targ);
 899         int flip = 0;
 900
 901         if (PL_op->op_private & OPpFLIP_LINENUM) {
 902             if (GvIO(PL_last_in_gv)) {
 903                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
 904             }
 905             else {
 906                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
 907                 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
 908             }
 909         } else {
 910             flip = SvTRUE(sv);
 911         }
 912         if (flip) {
 913             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
 914             if (PL_op->op_flags & OPf_SPECIAL) {
 915                 sv_setiv(targ, 1);
 916                 SETs(targ);
 917                 RETURN;
 918             }
 919             else {
 920                 sv_setiv(targ, 0);
 921                 SP--;
 922                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
 923             }
 924         }
 925         sv_setpv(TARG, "");
 926         SETs(targ);
 927         RETURN;
 928     }
 929 }
 930
 931 PP(pp_flop)
 932 {
 933     dSP;
 934
 935     if (GIMME == G_ARRAY) {
 936         dPOPPOPssrl;
 937         register I32 i, j;
 938         register SV *sv;
 939         I32 max;
 940
 941         if (SvGMAGICAL(left))
 942             mg_get(left);
 943         if (SvGMAGICAL(right))
 944             mg_get(right);
 945
 946         if (SvNIOKp(left) || !SvPOKp(left) ||
 947             SvNIOKp(right) || !SvPOKp(right) ||
 948             (looks_like_number(left) && *SvPVX(left) != '0' &&
 949              looks_like_number(right) && *SvPVX(right) != '0'))
 950         {
 951             if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
 952                 DIE(aTHX_ "Range iterator outside integer range");
 953             i = SvIV(left);
 954             max = SvIV(right);
 955             if (max >= i) {
 956                 j = max - i + 1;
 957                 EXTEND_MORTAL(j);
 958                 EXTEND(SP, j);
 959             }
 960             else
 961                 j = 0;
 962             while (j--) {
 963                 sv = sv_2mortal(newSViv(i++));
 964                 PUSHs(sv);
 965             }
 966         }
 967         else {
 968             SV *final = sv_mortalcopy(right);
 969             STRLEN len, n_a;
 970             char *tmps = SvPV(final, len);
 971
 972             sv = sv_mortalcopy(left);
 973             SvPV_force(sv,n_a);
 974             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
 975                 XPUSHs(sv);
 976                 if (strEQ(SvPVX(sv),tmps))
 977                     break;
 978                 sv = sv_2mortal(newSVsv(sv));
 979                 sv_inc(sv);
 980             }
 981         }
 982     }
 983     else {
 984         dTOPss;
 985         SV *targ = PAD_SV(cUNOP->op_first->op_targ);
 986         int flop = 0;
 987         sv_inc(targ);
 988
 989         if (PL_op->op_private & OPpFLIP_LINENUM) {
 990             if (GvIO(PL_last_in_gv)) {
 991                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
 992             }
 993             else {
 994                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
 995                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
 996             }
 997         }
 998         else {
 999             flop = SvTRUE(sv);
1000         }
1001
1002         if (flop) {
1003             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1004             sv_catpv(targ, "E0");
1005         }
1006         SETs(targ);
1007     }
1008
1009     RETURN;
1010 }
1011
1012 /* Control. */
1013
1014 STATIC I32
1015 S_dopoptolabel(pTHX_ char *label)
1016 {
1017     register I32 i;
1018     register PERL_CONTEXT *cx;
1019
1020     for (i = cxstack_ix; i >= 0; i--) {
1021         cx = &cxstack[i];
1022         switch (CxTYPE(cx)) {
1023         case CXt_SUBST:
1024             if (ckWARN(WARN_EXITING))
1025                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
1026                         OP_NAME(PL_op));
1027             break;
1028         case CXt_SUB:
1029             if (ckWARN(WARN_EXITING))
1030                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
1031                         OP_NAME(PL_op));
1032             break;
1033         case CXt_FORMAT:
1034             if (ckWARN(WARN_EXITING))
1035                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
1036                         OP_NAME(PL_op));
1037             break;
1038         case CXt_EVAL:
1039             if (ckWARN(WARN_EXITING))
1040                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
1041                         OP_NAME(PL_op));
1042             break;
1043         case CXt_NULL:
1044             if (ckWARN(WARN_EXITING))
1045                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
1046                         OP_NAME(PL_op));
1047             return -1;
1048         case CXt_LOOP:
1049             if (!cx->blk_loop.label ||
1050               strNE(label, cx->blk_loop.label) ) {
1051                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1052                         (long)i, cx->blk_loop.label));
1053                 continue;
1054             }
1055             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1056             return i;
1057         }
1058     }
1059     return i;
1060 }
1061
1062 I32
1063 Perl_dowantarray(pTHX)
1064 {
1065     I32 gimme = block_gimme();
1066     return (gimme == G_VOID) ? G_SCALAR : gimme;
1067 }
1068
1069 I32
1070 Perl_block_gimme(pTHX)
1071 {
1072     I32 cxix;
1073
1074     cxix = dopoptosub(cxstack_ix);
1075     if (cxix < 0)
1076         return G_VOID;
1077
1078     switch (cxstack[cxix].blk_gimme) {
1079     case G_VOID:
1080         return G_VOID;
1081     case G_SCALAR:
1082         return G_SCALAR;
1083     case G_ARRAY:
1084         return G_ARRAY;
1085     default:
1086         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1087         /* NOTREACHED */
1088         return 0;
1089     }
1090 }
1091
1092 I32
1093 Perl_is_lvalue_sub(pTHX)
1094 {
1095     I32 cxix;
1096
1097     cxix = dopoptosub(cxstack_ix);
1098     assert(cxix >= 0);  /* We should only be called from inside subs */
1099
1100     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1101         return cxstack[cxix].blk_sub.lval;
1102     else
1103         return 0;
1104 }
1105
1106 STATIC I32
1107 S_dopoptosub(pTHX_ I32 startingblock)
1108 {
1109     return dopoptosub_at(cxstack, startingblock);
1110 }
1111
1112 STATIC I32
1113 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1114 {
1115     I32 i;
1116     register PERL_CONTEXT *cx;
1117     for (i = startingblock; i >= 0; i--) {
1118         cx = &cxstk[i];
1119         switch (CxTYPE(cx)) {
1120         default:
1121             continue;
1122         case CXt_EVAL:
1123         case CXt_SUB:
1124         case CXt_FORMAT:
1125             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1126             return i;
1127         }
1128     }
1129     return i;
1130 }
1131
1132 STATIC I32
1133 S_dopoptoeval(pTHX_ I32 startingblock)
1134 {
1135     I32 i;
1136     register PERL_CONTEXT *cx;
1137     for (i = startingblock; i >= 0; i--) {
1138         cx = &cxstack[i];
1139         switch (CxTYPE(cx)) {
1140         default:
1141             continue;
1142         case CXt_EVAL:
1143             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1144             return i;
1145         }
1146     }
1147     return i;
1148 }
1149
1150 STATIC I32
1151 S_dopoptoloop(pTHX_ I32 startingblock)
1152 {
1153     I32 i;
1154     register PERL_CONTEXT *cx;
1155     for (i = startingblock; i >= 0; i--) {
1156         cx = &cxstack[i];
1157         switch (CxTYPE(cx)) {
1158         case CXt_SUBST:
1159             if (ckWARN(WARN_EXITING))
1160                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
1161                         OP_NAME(PL_op));
1162             break;
1163         case CXt_SUB:
1164             if (ckWARN(WARN_EXITING))
1165                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
1166                         OP_NAME(PL_op));
1167             break;
1168         case CXt_FORMAT:
1169             if (ckWARN(WARN_EXITING))
1170                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
1171                         OP_NAME(PL_op));
1172             break;
1173         case CXt_EVAL:
1174             if (ckWARN(WARN_EXITING))
1175                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
1176                         OP_NAME(PL_op));
1177             break;
1178         case CXt_NULL:
1179             if (ckWARN(WARN_EXITING))
1180                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
1181                         OP_NAME(PL_op));
1182             return -1;
1183         case CXt_LOOP:
1184             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1185             return i;
1186         }
1187     }
1188     return i;
1189 }
1190
1191 void
1192 Perl_dounwind(pTHX_ I32 cxix)
1193 {
1194     register PERL_CONTEXT *cx;
1195     I32 optype;
1196
1197     while (cxstack_ix > cxix) {
1198         SV *sv;
1199         cx = &cxstack[cxstack_ix];
1200         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1201                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1202         /* Note: we don't need to restore the base context info till the end. */
1203         switch (CxTYPE(cx)) {
1204         case CXt_SUBST:
1205             POPSUBST(cx);
1206             continue;  /* not break */
1207         case CXt_SUB:
1208             POPSUB(cx,sv);
1209             LEAVESUB(sv);
1210             break;
1211         case CXt_EVAL:
1212             POPEVAL(cx);
1213             break;
1214         case CXt_LOOP:
1215             POPLOOP(cx);
1216             break;
1217         case CXt_NULL:
1218             break;
1219         case CXt_FORMAT:
1220             POPFORMAT(cx);
1221             break;
1222         }
1223         cxstack_ix--;
1224     }
1225 }
1226
1227 void
1228 Perl_qerror(pTHX_ SV *err)
1229 {
1230     if (PL_in_eval)
1231         sv_catsv(ERRSV, err);
1232     else if (PL_errors)
1233         sv_catsv(PL_errors, err);
1234     else
1235         Perl_warn(aTHX_ "%"SVf, err);
1236     ++PL_error_count;
1237 }
1238
1239 OP *
1240 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1241 {
1242     STRLEN n_a;
1243     IO *io;
1244     MAGIC *mg;
1245
1246     if (PL_in_eval) {
1247         I32 cxix;
1248         register PERL_CONTEXT *cx;
1249         I32 gimme;
1250         SV **newsp;
1251
1252         if (message) {
1253             if (PL_in_eval & EVAL_KEEPERR) {
1254                 static char prefix[] = "\t(in cleanup) ";
1255                 SV *err = ERRSV;
1256                 char *e = Nullch;
1257                 if (!SvPOK(err))
1258                     sv_setpv(err,"");
1259                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1260                     e = SvPV(err, n_a);
1261                     e += n_a - msglen;
1262                     if (*e != *message || strNE(e,message))
1263                         e = Nullch;
1264                 }
1265                 if (!e) {
1266                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1267                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1268                     sv_catpvn(err, message, msglen);
1269                     if (ckWARN(WARN_MISC)) {
1270                         STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1271                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1272                     }
1273                 }
1274             }
1275             else {
1276                 sv_setpvn(ERRSV, message, msglen);
1277             }
1278         }
1279         else
1280             message = SvPVx(ERRSV, msglen);
1281
1282         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1283                && PL_curstackinfo->si_prev)
1284         {
1285             dounwind(-1);
1286             POPSTACK;
1287         }
1288
1289         if (cxix >= 0) {
1290             I32 optype;
1291
1292             if (cxix < cxstack_ix)
1293                 dounwind(cxix);
1294
1295             POPBLOCK(cx,PL_curpm);
1296             if (CxTYPE(cx) != CXt_EVAL) {
1297                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1298                 PerlIO_write(Perl_error_log, message, msglen);
1299                 my_exit(1);
1300             }
1301             POPEVAL(cx);
1302
1303             if (gimme == G_SCALAR)
1304                 *++newsp = &PL_sv_undef;
1305             PL_stack_sp = newsp;
1306
1307             LEAVE;
1308
1309             /* LEAVE could clobber PL_curcop (see save_re_context())
1310              * XXX it might be better to find a way to avoid messing with
1311              * PL_curcop in save_re_context() instead, but this is a more
1312              * minimal fix --GSAR */
1313             PL_curcop = cx->blk_oldcop;
1314
1315             if (optype == OP_REQUIRE) {
1316                 char* msg = SvPVx(ERRSV, n_a);
1317                 DIE(aTHX_ "%sCompilation failed in require",
1318                     *msg ? msg : "Unknown error\n");
1319             }
1320             return pop_return();
1321         }
1322     }
1323     if (!message)
1324         message = SvPVx(ERRSV, msglen);
1325
1326     /* if STDERR is tied, print to it instead */
1327     if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1328         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1329         dSP; ENTER;
1330         PUSHMARK(SP);
1331         XPUSHs(SvTIED_obj((SV*)io, mg));
1332         XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1333         PUTBACK;
1334         call_method("PRINT", G_SCALAR);
1335         LEAVE;
1336     }
1337     else {
1338 #ifdef USE_SFIO
1339         /* SFIO can really mess with your errno */
1340         int e = errno;
1341 #endif
1342         PerlIO *serr = Perl_error_log;
1343
1344         PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1345         (void)PerlIO_flush(serr);
1346 #ifdef USE_SFIO
1347         errno = e;
1348 #endif
1349     }
1350     my_failure_exit();
1351     /* NOTREACHED */
1352     return 0;
1353 }
1354
1355 PP(pp_xor)
1356 {
1357     dSP; dPOPTOPssrl;
1358     if (SvTRUE(left) != SvTRUE(right))
1359         RETSETYES;
1360     else
1361         RETSETNO;
1362 }
1363
1364 PP(pp_andassign)
1365 {
1366     dSP;
1367     if (!SvTRUE(TOPs))
1368         RETURN;
1369     else
1370         RETURNOP(cLOGOP->op_other);
1371 }
1372
1373 PP(pp_orassign)
1374 {
1375     dSP;
1376     if (SvTRUE(TOPs))
1377         RETURN;
1378     else
1379         RETURNOP(cLOGOP->op_other);
1380 }
1381
1382 PP(pp_dorassign)
1383 {
1384     dSP;
1385     register SV* sv;
1386
1387     sv = TOPs;
1388     if (!sv || !SvANY(sv)) {
1389         RETURNOP(cLOGOP->op_other);
1390     }
1391
1392     switch (SvTYPE(sv)) {
1393     case SVt_PVAV:
1394         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1395             RETURN;
1396         break;
1397     case SVt_PVHV:
1398         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1399             RETURN;
1400         break;
1401     case SVt_PVCV:
1402         if (CvROOT(sv) || CvXSUB(sv))
1403             RETURN;
1404         break;
1405     default:
1406         if (SvGMAGICAL(sv))
1407             mg_get(sv);
1408         if (SvOK(sv))
1409             RETURN;
1410     }
1411
1412     RETURNOP(cLOGOP->op_other);
1413 }
1414
1415 PP(pp_caller)
1416 {
1417     dSP;
1418     register I32 cxix = dopoptosub(cxstack_ix);
1419     register PERL_CONTEXT *cx;
1420     register PERL_CONTEXT *ccstack = cxstack;
1421     PERL_SI *top_si = PL_curstackinfo;
1422     I32 dbcxix;
1423     I32 gimme;
1424     char *stashname;
1425     SV *sv;
1426     I32 count = 0;
1427
1428     if (MAXARG)
1429         count = POPi;
1430
1431     for (;;) {
1432         /* we may be in a higher stacklevel, so dig down deeper */
1433         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1434             top_si = top_si->si_prev;
1435             ccstack = top_si->si_cxstack;
1436             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1437         }
1438         if (cxix < 0) {
1439             if (GIMME != G_ARRAY) {
1440                 EXTEND(SP, 1);
1441                 RETPUSHUNDEF;
1442             }
1443             RETURN;
1444         }
1445         if (PL_DBsub && cxix >= 0 &&
1446                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1447             count++;
1448         if (!count--)
1449             break;
1450         cxix = dopoptosub_at(ccstack, cxix - 1);
1451     }
1452
1453     cx = &ccstack[cxix];
1454     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1455         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1456         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1457            field below is defined for any cx. */
1458         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1459             cx = &ccstack[dbcxix];
1460     }
1461
1462     stashname = CopSTASHPV(cx->blk_oldcop);
1463     if (GIMME != G_ARRAY) {
1464         EXTEND(SP, 1);
1465         if (!stashname)
1466             PUSHs(&PL_sv_undef);
1467         else {
1468             dTARGET;
1469             sv_setpv(TARG, stashname);
1470             PUSHs(TARG);
1471         }
1472         RETURN;
1473     }
1474
1475     EXTEND(SP, 10);
1476
1477     if (!stashname)
1478         PUSHs(&PL_sv_undef);
1479     else
1480         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1481     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1482     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1483     if (!MAXARG)
1484         RETURN;
1485     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1486         GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1487         /* So is ccstack[dbcxix]. */
1488         if (isGV(cvgv)) {
1489             sv = NEWSV(49, 0);
1490             gv_efullname3(sv, cvgv, Nullch);
1491             PUSHs(sv_2mortal(sv));
1492             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1493         }
1494         else {
1495             PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1496             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1497         }
1498     }
1499     else {
1500         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1501         PUSHs(sv_2mortal(newSViv(0)));
1502     }
1503     gimme = (I32)cx->blk_gimme;
1504     if (gimme == G_VOID)
1505         PUSHs(&PL_sv_undef);
1506     else
1507         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1508     if (CxTYPE(cx) == CXt_EVAL) {
1509         /* eval STRING */
1510         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1511             PUSHs(cx->blk_eval.cur_text);
1512             PUSHs(&PL_sv_no);
1513         }
1514         /* require */
1515         else if (cx->blk_eval.old_namesv) {
1516             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1517             PUSHs(&PL_sv_yes);
1518         }
1519         /* eval BLOCK (try blocks have old_namesv == 0) */
1520         else {
1521             PUSHs(&PL_sv_undef);
1522             PUSHs(&PL_sv_undef);
1523         }
1524     }
1525     else {
1526         PUSHs(&PL_sv_undef);
1527         PUSHs(&PL_sv_undef);
1528     }
1529     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1530         && CopSTASH_eq(PL_curcop, PL_debstash))
1531     {
1532         AV *ary = cx->blk_sub.argarray;
1533         int off = AvARRAY(ary) - AvALLOC(ary);
1534
1535         if (!PL_dbargs) {
1536             GV* tmpgv;
1537             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1538                                 SVt_PVAV)));
1539             GvMULTI_on(tmpgv);
1540             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1541         }
1542
1543         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1544             av_extend(PL_dbargs, AvFILLp(ary) + off);
1545         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1546         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1547     }
1548     /* XXX only hints propagated via op_private are currently
1549      * visible (others are not easily accessible, since they
1550      * use the global PL_hints) */
1551     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1552                              HINT_PRIVATE_MASK)));
1553     {
1554         SV * mask ;
1555         SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1556
1557         if  (old_warnings == pWARN_NONE ||
1558                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1559             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1560         else if (old_warnings == pWARN_ALL ||
1561                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1562             mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1563         else
1564             mask = newSVsv(old_warnings);
1565         PUSHs(sv_2mortal(mask));
1566     }
1567     RETURN;
1568 }
1569
1570 PP(pp_reset)
1571 {
1572     dSP;
1573     char *tmps;
1574     STRLEN n_a;
1575
1576     if (MAXARG < 1)
1577         tmps = "";
1578     else
1579         tmps = POPpx;
1580     sv_reset(tmps, CopSTASH(PL_curcop));
1581     PUSHs(&PL_sv_yes);
1582     RETURN;
1583 }
1584
1585 PP(pp_lineseq)
1586 {
1587     return NORMAL;
1588 }
1589
1590 /* like pp_nextstate, but used instead when the debugger is active */
1591
1592 PP(pp_dbstate)
1593 {
1594     PL_curcop = (COP*)PL_op;
1595     TAINT_NOT;          /* Each statement is presumed innocent */
1596     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1597     FREETMPS;
1598
1599     if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1600     {
1601         dSP;
1602         register CV *cv;
1603         register PERL_CONTEXT *cx;
1604         I32 gimme = G_ARRAY;
1605         U8 hasargs;
1606         GV *gv;
1607
1608         gv = PL_DBgv;
1609         cv = GvCV(gv);
1610         if (!cv)
1611             DIE(aTHX_ "No DB::DB routine defined");
1612
1613         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1614             /* don't do recursive DB::DB call */
1615             return NORMAL;
1616
1617         ENTER;
1618         SAVETMPS;
1619
1620         SAVEI32(PL_debug);
1621         SAVESTACK_POS();
1622         PL_debug = 0;
1623         hasargs = 0;
1624         SPAGAIN;
1625
1626         push_return(PL_op->op_next);
1627         PUSHBLOCK(cx, CXt_SUB, SP);
1628         PUSHSUB(cx);
1629         CvDEPTH(cv)++;
1630         (void)SvREFCNT_inc(cv);
1631         PAD_SET_CUR(CvPADLIST(cv),1);
1632         RETURNOP(CvSTART(cv));
1633     }
1634     else
1635         return NORMAL;
1636 }
1637
1638 PP(pp_scope)
1639 {
1640     return NORMAL;
1641 }
1642
1643 PP(pp_enteriter)
1644 {
1645     dSP; dMARK;
1646     register PERL_CONTEXT *cx;
1647     I32 gimme = GIMME_V;
1648     SV **svp;
1649     U32 cxtype = CXt_LOOP;
1650 #ifdef USE_ITHREADS
1651     void *iterdata;
1652 #endif
1653
1654     ENTER;
1655     SAVETMPS;
1656
1657 #ifdef USE_5005THREADS
1658     if (PL_op->op_flags & OPf_SPECIAL) {
1659         svp = &THREADSV(PL_op->op_targ);        /* per-thread variable */
1660         SAVEGENERICSV(*svp);
1661         *svp = NEWSV(0,0);
1662     }
1663     else
1664 #endif /* USE_5005THREADS */
1665     if (PL_op->op_targ) {
1666 #ifndef USE_ITHREADS
1667         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1668         SAVESPTR(*svp);
1669 #else
1670         SAVEPADSV(PL_op->op_targ);
1671         iterdata = INT2PTR(void*, PL_op->op_targ);
1672         cxtype |= CXp_PADVAR;
1673 #endif
1674     }
1675     else {
1676         GV *gv = (GV*)POPs;
1677         svp = &GvSV(gv);                        /* symbol table variable */
1678         SAVEGENERICSV(*svp);
1679         *svp = NEWSV(0,0);
1680 #ifdef USE_ITHREADS
1681         iterdata = (void*)gv;
1682 #endif
1683     }
1684
1685     ENTER;
1686
1687     PUSHBLOCK(cx, cxtype, SP);
1688 #ifdef USE_ITHREADS
1689     PUSHLOOP(cx, iterdata, MARK);
1690 #else
1691     PUSHLOOP(cx, svp, MARK);
1692 #endif
1693     if (PL_op->op_flags & OPf_STACKED) {
1694         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1695         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1696             dPOPss;
1697             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1698                 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1699                 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1700                  looks_like_number((SV*)cx->blk_loop.iterary) &&
1701                  *SvPVX(cx->blk_loop.iterary) != '0'))
1702             {
1703                  if (SvNV(sv) < IV_MIN ||
1704                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1705                      DIE(aTHX_ "Range iterator outside integer range");
1706                  cx->blk_loop.iterix = SvIV(sv);
1707                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1708             }
1709             else
1710                 cx->blk_loop.iterlval = newSVsv(sv);
1711         }
1712     }
1713     else {
1714         cx->blk_loop.iterary = PL_curstack;
1715         AvFILLp(PL_curstack) = SP - PL_stack_base;
1716         cx->blk_loop.iterix = MARK - PL_stack_base;
1717     }
1718
1719     RETURN;
1720 }
1721
1722 PP(pp_enterloop)
1723 {
1724     dSP;
1725     register PERL_CONTEXT *cx;
1726     I32 gimme = GIMME_V;
1727
1728     ENTER;
1729     SAVETMPS;
1730     ENTER;
1731
1732     PUSHBLOCK(cx, CXt_LOOP, SP);
1733     PUSHLOOP(cx, 0, SP);
1734
1735     RETURN;
1736 }
1737
1738 PP(pp_leaveloop)
1739 {
1740     dSP;
1741     register PERL_CONTEXT *cx;
1742     I32 gimme;
1743     SV **newsp;
1744     PMOP *newpm;
1745     SV **mark;
1746
1747     POPBLOCK(cx,newpm);
1748     mark = newsp;
1749     newsp = PL_stack_base + cx->blk_loop.resetsp;
1750
1751     TAINT_NOT;
1752     if (gimme == G_VOID)
1753         ; /* do nothing */
1754     else if (gimme == G_SCALAR) {
1755         if (mark < SP)
1756             *++newsp = sv_mortalcopy(*SP);
1757         else
1758             *++newsp = &PL_sv_undef;
1759     }
1760     else {
1761         while (mark < SP) {
1762             *++newsp = sv_mortalcopy(*++mark);
1763             TAINT_NOT;          /* Each item is independent */
1764         }
1765     }
1766     SP = newsp;
1767     PUTBACK;
1768
1769     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1770     PL_curpm = newpm;   /* ... and pop $1 et al */
1771
1772     LEAVE;
1773     LEAVE;
1774
1775     return NORMAL;
1776 }
1777
1778 PP(pp_return)
1779 {
1780     dSP; dMARK;
1781     I32 cxix;
1782     register PERL_CONTEXT *cx;
1783     bool popsub2 = FALSE;
1784     bool clear_errsv = FALSE;
1785     I32 gimme;
1786     SV **newsp;
1787     PMOP *newpm;
1788     I32 optype = 0;
1789     SV *sv;
1790
1791     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1792         if (cxstack_ix == PL_sortcxix
1793             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1794         {
1795             if (cxstack_ix > PL_sortcxix)
1796                 dounwind(PL_sortcxix);
1797             AvARRAY(PL_curstack)[1] = *SP;
1798             PL_stack_sp = PL_stack_base + 1;
1799             return 0;
1800         }
1801     }
1802
1803     cxix = dopoptosub(cxstack_ix);
1804     if (cxix < 0)
1805         DIE(aTHX_ "Can't return outside a subroutine");
1806     if (cxix < cxstack_ix)
1807         dounwind(cxix);
1808
1809     POPBLOCK(cx,newpm);
1810     switch (CxTYPE(cx)) {
1811     case CXt_SUB:
1812         popsub2 = TRUE;
1813         break;
1814     case CXt_EVAL:
1815         if (!(PL_in_eval & EVAL_KEEPERR))
1816             clear_errsv = TRUE;
1817         POPEVAL(cx);
1818         if (CxTRYBLOCK(cx))
1819             break;
1820         lex_end();
1821         if (optype == OP_REQUIRE &&
1822             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1823         {
1824             /* Unassume the success we assumed earlier. */
1825             SV *nsv = cx->blk_eval.old_namesv;
1826             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1827             DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1828         }
1829         break;
1830     case CXt_FORMAT:
1831         POPFORMAT(cx);
1832         break;
1833     default:
1834         DIE(aTHX_ "panic: return");
1835     }
1836
1837     TAINT_NOT;
1838     if (gimme == G_SCALAR) {
1839         if (MARK < SP) {
1840             if (popsub2) {
1841                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1842                     if (SvTEMP(TOPs)) {
1843                         *++newsp = SvREFCNT_inc(*SP);
1844                         FREETMPS;
1845                         sv_2mortal(*newsp);
1846                     }
1847                     else {
1848                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1849                         FREETMPS;
1850                         *++newsp = sv_mortalcopy(sv);
1851                         SvREFCNT_dec(sv);
1852                     }
1853                 }
1854                 else
1855                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1856             }
1857             else
1858                 *++newsp = sv_mortalcopy(*SP);
1859         }
1860         else
1861             *++newsp = &PL_sv_undef;
1862     }
1863     else if (gimme == G_ARRAY) {
1864         while (++MARK <= SP) {
1865             *++newsp = (popsub2 && SvTEMP(*MARK))
1866                         ? *MARK : sv_mortalcopy(*MARK);
1867             TAINT_NOT;          /* Each item is independent */
1868         }
1869     }
1870     PL_stack_sp = newsp;
1871
1872     /* Stack values are safe: */
1873     if (popsub2) {
1874         POPSUB(cx,sv);  /* release CV and @_ ... */
1875     }
1876     else
1877         sv = Nullsv;
1878     PL_curpm = newpm;   /* ... and pop $1 et al */
1879
1880     LEAVE;
1881     LEAVESUB(sv);
1882     if (clear_errsv)
1883         sv_setpv(ERRSV,"");
1884     return pop_return();
1885 }
1886
1887 PP(pp_last)
1888 {
1889     dSP;
1890     I32 cxix;
1891     register PERL_CONTEXT *cx;
1892     I32 pop2 = 0;
1893     I32 gimme;
1894     I32 optype;
1895     OP *nextop;
1896     SV **newsp;
1897     PMOP *newpm;
1898     SV **mark;
1899     SV *sv = Nullsv;
1900
1901     if (PL_op->op_flags & OPf_SPECIAL) {
1902         cxix = dopoptoloop(cxstack_ix);
1903         if (cxix < 0)
1904             DIE(aTHX_ "Can't \"last\" outside a loop block");
1905     }
1906     else {
1907         cxix = dopoptolabel(cPVOP->op_pv);
1908         if (cxix < 0)
1909             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1910     }
1911     if (cxix < cxstack_ix)
1912         dounwind(cxix);
1913
1914     POPBLOCK(cx,newpm);
1915     mark = newsp;
1916     switch (CxTYPE(cx)) {
1917     case CXt_LOOP:
1918         pop2 = CXt_LOOP;
1919         newsp = PL_stack_base + cx->blk_loop.resetsp;
1920         nextop = cx->blk_loop.last_op->op_next;
1921         break;
1922     case CXt_SUB:
1923         pop2 = CXt_SUB;
1924         nextop = pop_return();
1925         break;
1926     case CXt_EVAL:
1927         POPEVAL(cx);
1928         nextop = pop_return();
1929         break;
1930     case CXt_FORMAT:
1931         POPFORMAT(cx);
1932         nextop = pop_return();
1933         break;
1934     default:
1935         DIE(aTHX_ "panic: last");
1936     }
1937
1938     TAINT_NOT;
1939     if (gimme == G_SCALAR) {
1940         if (MARK < SP)
1941             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1942                         ? *SP : sv_mortalcopy(*SP);
1943         else
1944             *++newsp = &PL_sv_undef;
1945     }
1946     else if (gimme == G_ARRAY) {
1947         while (++MARK <= SP) {
1948             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1949                         ? *MARK : sv_mortalcopy(*MARK);
1950             TAINT_NOT;          /* Each item is independent */
1951         }
1952     }
1953     SP = newsp;
1954     PUTBACK;
1955
1956     /* Stack values are safe: */
1957     switch (pop2) {
1958     case CXt_LOOP:
1959         POPLOOP(cx);    /* release loop vars ... */
1960         LEAVE;
1961         break;
1962     case CXt_SUB:
1963         POPSUB(cx,sv);  /* release CV and @_ ... */
1964         break;
1965     }
1966     PL_curpm = newpm;   /* ... and pop $1 et al */
1967
1968     LEAVE;
1969     LEAVESUB(sv);
1970     return nextop;
1971 }
1972
1973 PP(pp_next)
1974 {
1975     I32 cxix;
1976     register PERL_CONTEXT *cx;
1977     I32 inner;
1978
1979     if (PL_op->op_flags & OPf_SPECIAL) {
1980         cxix = dopoptoloop(cxstack_ix);
1981         if (cxix < 0)
1982             DIE(aTHX_ "Can't \"next\" outside a loop block");
1983     }
1984     else {
1985         cxix = dopoptolabel(cPVOP->op_pv);
1986         if (cxix < 0)
1987             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1988     }
1989     if (cxix < cxstack_ix)
1990         dounwind(cxix);
1991
1992     /* clear off anything above the scope we're re-entering, but
1993      * save the rest until after a possible continue block */
1994     inner = PL_scopestack_ix;
1995     TOPBLOCK(cx);
1996     if (PL_scopestack_ix < inner)
1997         leave_scope(PL_scopestack[PL_scopestack_ix]);
1998     return cx->blk_loop.next_op;
1999 }
2000
2001 PP(pp_redo)
2002 {
2003     I32 cxix;
2004     register PERL_CONTEXT *cx;
2005     I32 oldsave;
2006
2007     if (PL_op->op_flags & OPf_SPECIAL) {
2008         cxix = dopoptoloop(cxstack_ix);
2009         if (cxix < 0)
2010             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2011     }
2012     else {
2013         cxix = dopoptolabel(cPVOP->op_pv);
2014         if (cxix < 0)
2015             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2016     }
2017     if (cxix < cxstack_ix)
2018         dounwind(cxix);
2019
2020     TOPBLOCK(cx);
2021     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2022     LEAVE_SCOPE(oldsave);
2023     return cx->blk_loop.redo_op;
2024 }
2025
2026 STATIC OP *
2027 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2028 {
2029     OP *kid = Nullop;
2030     OP **ops = opstack;
2031     static char too_deep[] = "Target of goto is too deeply nested";
2032
2033     if (ops >= oplimit)
2034         Perl_croak(aTHX_ too_deep);
2035     if (o->op_type == OP_LEAVE ||
2036         o->op_type == OP_SCOPE ||
2037         o->op_type == OP_LEAVELOOP ||
2038         o->op_type == OP_LEAVETRY)
2039     {
2040         *ops++ = cUNOPo->op_first;
2041         if (ops >= oplimit)
2042             Perl_croak(aTHX_ too_deep);
2043     }
2044     *ops = 0;
2045     if (o->op_flags & OPf_KIDS) {
2046         /* First try all the kids at this level, since that's likeliest. */
2047         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2048             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2049                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2050                 return kid;
2051         }
2052         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2053             if (kid == PL_lastgotoprobe)
2054                 continue;
2055             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2056                 (ops == opstack ||
2057                  (ops[-1]->op_type != OP_NEXTSTATE &&
2058                   ops[-1]->op_type != OP_DBSTATE)))
2059                 *ops++ = kid;
2060             if ((o = dofindlabel(kid, label, ops, oplimit)))
2061                 return o;
2062         }
2063     }
2064     *ops = 0;
2065     return 0;
2066 }
2067
2068 PP(pp_dump)
2069 {
2070     return pp_goto();
2071     /*NOTREACHED*/
2072 }
2073
2074 PP(pp_goto)
2075 {
2076     dSP;
2077     OP *retop = 0;
2078     I32 ix;
2079     register PERL_CONTEXT *cx;
2080 #define GOTO_DEPTH 64
2081     OP *enterops[GOTO_DEPTH];
2082     char *label;
2083     int do_dump = (PL_op->op_type == OP_DUMP);
2084     static char must_have_label[] = "goto must have label";
2085
2086     label = 0;
2087     if (PL_op->op_flags & OPf_STACKED) {
2088         SV *sv = POPs;
2089         STRLEN n_a;
2090
2091         /* This egregious kludge implements goto &subroutine */
2092         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2093             I32 cxix;
2094             register PERL_CONTEXT *cx;
2095             CV* cv = (CV*)SvRV(sv);
2096             SV** mark;
2097             I32 items = 0;
2098             I32 oldsave;
2099
2100         retry:
2101             if (!CvROOT(cv) && !CvXSUB(cv)) {
2102                 GV *gv = CvGV(cv);
2103                 GV *autogv;
2104                 if (gv) {
2105                     SV *tmpstr;
2106                     /* autoloaded stub? */
2107                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2108                         goto retry;
2109                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2110                                           GvNAMELEN(gv), FALSE);
2111                     if (autogv && (cv = GvCV(autogv)))
2112                         goto retry;
2113                     tmpstr = sv_newmortal();
2114                     gv_efullname3(tmpstr, gv, Nullch);
2115                     DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2116                 }
2117                 DIE(aTHX_ "Goto undefined subroutine");
2118             }
2119
2120             /* First do some returnish stuff. */
2121             cxix = dopoptosub(cxstack_ix);
2122             if (cxix < 0)
2123                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2124             if (cxix < cxstack_ix)
2125                 dounwind(cxix);
2126             TOPBLOCK(cx);
2127             if (CxREALEVAL(cx))
2128                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2129             mark = PL_stack_sp;
2130             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2131                 /* put @_ back onto stack */
2132                 AV* av = cx->blk_sub.argarray;
2133
2134                 items = AvFILLp(av) + 1;
2135                 PL_stack_sp++;
2136                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2137                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2138                 PL_stack_sp += items;
2139 #ifndef USE_5005THREADS
2140                 SvREFCNT_dec(GvAV(PL_defgv));
2141                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2142 #endif /* USE_5005THREADS */
2143                 /* abandon @_ if it got reified */
2144                 if (AvREAL(av)) {
2145                     (void)sv_2mortal((SV*)av);  /* delay until return */
2146                     av = newAV();
2147                     av_extend(av, items-1);
2148                     AvFLAGS(av) = AVf_REIFY;
2149                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2150                 }
2151             }
2152             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2153                 AV* av;
2154 #ifdef USE_5005THREADS
2155                 av = (AV*)PAD_SVl(0);
2156 #else
2157                 av = GvAV(PL_defgv);
2158 #endif
2159                 items = AvFILLp(av) + 1;
2160                 PL_stack_sp++;
2161                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2162                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2163                 PL_stack_sp += items;
2164             }
2165             if (CxTYPE(cx) == CXt_SUB &&
2166                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2167                 SvREFCNT_dec(cx->blk_sub.cv);
2168             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2169             LEAVE_SCOPE(oldsave);
2170
2171             /* Now do some callish stuff. */
2172             SAVETMPS;
2173             if (CvXSUB(cv)) {
2174 #ifdef PERL_XSUB_OLDSTYLE
2175                 if (CvOLDSTYLE(cv)) {
2176                     I32 (*fp3)(int,int,int);
2177                     while (SP > mark) {
2178                         SP[1] = SP[0];
2179                         SP--;
2180                     }
2181                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2182                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2183                                    mark - PL_stack_base + 1,
2184                                    items);
2185                     SP = PL_stack_base + items;
2186                 }
2187                 else
2188 #endif /* PERL_XSUB_OLDSTYLE */
2189                 {
2190                     SV **newsp;
2191                     I32 gimme;
2192
2193                     PL_stack_sp--;              /* There is no cv arg. */
2194                     /* Push a mark for the start of arglist */
2195                     PUSHMARK(mark);
2196                     (void)(*CvXSUB(cv))(aTHX_ cv);
2197                     /* Pop the current context like a decent sub should */
2198                     POPBLOCK(cx, PL_curpm);
2199                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2200                 }
2201                 LEAVE;
2202                 return pop_return();
2203             }
2204             else {
2205                 AV* padlist = CvPADLIST(cv);
2206                 if (CxTYPE(cx) == CXt_EVAL) {
2207                     PL_in_eval = cx->blk_eval.old_in_eval;
2208                     PL_eval_root = cx->blk_eval.old_eval_root;
2209                     cx->cx_type = CXt_SUB;
2210                     cx->blk_sub.hasargs = 0;
2211                 }
2212                 cx->blk_sub.cv = cv;
2213                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2214
2215                 CvDEPTH(cv)++;
2216                 if (CvDEPTH(cv) < 2)
2217                     (void)SvREFCNT_inc(cv);
2218                 else {
2219                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2220                         sub_crush_depth(cv);
2221                     pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2222                 }
2223 #ifdef USE_5005THREADS
2224                 if (!cx->blk_sub.hasargs) {
2225                     AV* av = (AV*)PAD_SVl(0);
2226
2227                     items = AvFILLp(av) + 1;
2228                     if (items) {
2229                         /* Mark is at the end of the stack. */
2230                         EXTEND(SP, items);
2231                         Copy(AvARRAY(av), SP + 1, items, SV*);
2232                         SP += items;
2233                         PUTBACK ;
2234                     }
2235                 }
2236 #endif /* USE_5005THREADS */
2237                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2238 #ifndef USE_5005THREADS
2239                 if (cx->blk_sub.hasargs)
2240 #endif /* USE_5005THREADS */
2241                 {
2242                     AV* av = (AV*)PAD_SVl(0);
2243                     SV** ary;
2244
2245 #ifndef USE_5005THREADS
2246                     cx->blk_sub.savearray = GvAV(PL_defgv);
2247                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2248 #endif /* USE_5005THREADS */
2249                     CX_CURPAD_SAVE(cx->blk_sub);
2250                     cx->blk_sub.argarray = av;
2251                     ++mark;
2252
2253                     if (items >= AvMAX(av) + 1) {
2254                         ary = AvALLOC(av);
2255                         if (AvARRAY(av) != ary) {
2256                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2257                             SvPVX(av) = (char*)ary;
2258                         }
2259                         if (items >= AvMAX(av) + 1) {
2260                             AvMAX(av) = items - 1;
2261                             Renew(ary,items+1,SV*);
2262                             AvALLOC(av) = ary;
2263                             SvPVX(av) = (char*)ary;
2264                         }
2265                     }
2266                     Copy(mark,AvARRAY(av),items,SV*);
2267                     AvFILLp(av) = items - 1;
2268                     assert(!AvREAL(av));
2269                     while (items--) {
2270                         if (*mark)
2271                             SvTEMP_off(*mark);
2272                         mark++;
2273                     }
2274                 }
2275                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2276                     /*
2277                      * We do not care about using sv to call CV;
2278                      * it's for informational purposes only.
2279                      */
2280                     SV *sv = GvSV(PL_DBsub);
2281                     CV *gotocv;
2282
2283                     if (PERLDB_SUB_NN) {
2284                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2285                     } else {
2286                         save_item(sv);
2287                         gv_efullname3(sv, CvGV(cv), Nullch);
2288                     }
2289                     if (  PERLDB_GOTO
2290                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2291                         PUSHMARK( PL_stack_sp );
2292                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2293                         PL_stack_sp--;
2294                     }
2295                 }
2296                 RETURNOP(CvSTART(cv));
2297             }
2298         }
2299         else {
2300             label = SvPV(sv,n_a);
2301             if (!(do_dump || *label))
2302                 DIE(aTHX_ must_have_label);
2303         }
2304     }
2305     else if (PL_op->op_flags & OPf_SPECIAL) {
2306         if (! do_dump)
2307             DIE(aTHX_ must_have_label);
2308     }
2309     else
2310         label = cPVOP->op_pv;
2311
2312     if (label && *label) {
2313         OP *gotoprobe = 0;
2314         bool leaving_eval = FALSE;
2315         PERL_CONTEXT *last_eval_cx = 0;
2316
2317         /* find label */
2318
2319         PL_lastgotoprobe = 0;
2320         *enterops = 0;
2321         for (ix = cxstack_ix; ix >= 0; ix--) {
2322             cx = &cxstack[ix];
2323             switch (CxTYPE(cx)) {
2324             case CXt_EVAL:
2325                 leaving_eval = TRUE;
2326                 if (CxREALEVAL(cx)) {
2327                     gotoprobe = (last_eval_cx ?
2328                                 last_eval_cx->blk_eval.old_eval_root :
2329                                 PL_eval_root);
2330                     last_eval_cx = cx;
2331                     break;
2332                 }
2333                 /* else fall through */
2334             case CXt_LOOP:
2335                 gotoprobe = cx->blk_oldcop->op_sibling;
2336                 break;
2337             case CXt_SUBST:
2338                 continue;
2339             case CXt_BLOCK:
2340                 if (ix)
2341                     gotoprobe = cx->blk_oldcop->op_sibling;
2342                 else
2343                     gotoprobe = PL_main_root;
2344                 break;
2345             case CXt_SUB:
2346                 if (CvDEPTH(cx->blk_sub.cv)) {
2347                     gotoprobe = CvROOT(cx->blk_sub.cv);
2348                     break;
2349                 }
2350                 /* FALL THROUGH */
2351             case CXt_FORMAT:
2352             case CXt_NULL:
2353                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2354             default:
2355                 if (ix)
2356                     DIE(aTHX_ "panic: goto");
2357                 gotoprobe = PL_main_root;
2358                 break;
2359             }
2360             if (gotoprobe) {
2361                 retop = dofindlabel(gotoprobe, label,
2362                                     enterops, enterops + GOTO_DEPTH);
2363                 if (retop)
2364                     break;
2365             }
2366             PL_lastgotoprobe = gotoprobe;
2367         }
2368         if (!retop)
2369             DIE(aTHX_ "Can't find label %s", label);
2370
2371         /* if we're leaving an eval, check before we pop any frames
2372            that we're not going to punt, otherwise the error
2373            won't be caught */
2374
2375         if (leaving_eval && *enterops && enterops[1]) {
2376             I32 i;
2377             for (i = 1; enterops[i]; i++)
2378                 if (enterops[i]->op_type == OP_ENTERITER)
2379                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2380         }
2381
2382         /* pop unwanted frames */
2383
2384         if (ix < cxstack_ix) {
2385             I32 oldsave;
2386
2387             if (ix < 0)
2388                 ix = 0;
2389             dounwind(ix);
2390             TOPBLOCK(cx);
2391             oldsave = PL_scopestack[PL_scopestack_ix];
2392             LEAVE_SCOPE(oldsave);
2393         }
2394
2395         /* push wanted frames */
2396
2397         if (*enterops && enterops[1]) {
2398             OP *oldop = PL_op;
2399             for (ix = 1; enterops[ix]; ix++) {
2400                 PL_op = enterops[ix];
2401                 /* Eventually we may want to stack the needed arguments
2402                  * for each op.  For now, we punt on the hard ones. */
2403                 if (PL_op->op_type == OP_ENTERITER)
2404                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2405                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2406             }
2407             PL_op = oldop;
2408         }
2409     }
2410
2411     if (do_dump) {
2412 #ifdef VMS
2413         if (!retop) retop = PL_main_start;
2414 #endif
2415         PL_restartop = retop;
2416         PL_do_undump = TRUE;
2417
2418         my_unexec();
2419
2420         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2421         PL_do_undump = FALSE;
2422     }
2423
2424     RETURNOP(retop);
2425 }
2426
2427 PP(pp_exit)
2428 {
2429     dSP;
2430     I32 anum;
2431
2432     if (MAXARG < 1)
2433         anum = 0;
2434     else {
2435         anum = SvIVx(POPs);
2436 #ifdef VMS
2437         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2438             anum = 0;
2439         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2440 #endif
2441     }
2442     PL_exit_flags |= PERL_EXIT_EXPECTED;
2443     my_exit(anum);
2444     PUSHs(&PL_sv_undef);
2445     RETURN;
2446 }
2447
2448 #ifdef NOTYET
2449 PP(pp_nswitch)
2450 {
2451     dSP;
2452     NV value = SvNVx(GvSV(cCOP->cop_gv));
2453     register I32 match = I_32(value);
2454
2455     if (value < 0.0) {
2456         if (((NV)match) > value)
2457             --match;            /* was fractional--truncate other way */
2458     }
2459     match -= cCOP->uop.scop.scop_offset;
2460     if (match < 0)
2461         match = 0;
2462     else if (match > cCOP->uop.scop.scop_max)
2463         match = cCOP->uop.scop.scop_max;
2464     PL_op = cCOP->uop.scop.scop_next[match];
2465     RETURNOP(PL_op);
2466 }
2467
2468 PP(pp_cswitch)
2469 {
2470     dSP;
2471     register I32 match;
2472
2473     if (PL_multiline)
2474         PL_op = PL_op->op_next;                 /* can't assume anything */
2475     else {
2476         STRLEN n_a;
2477         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2478         match -= cCOP->uop.scop.scop_offset;
2479         if (match < 0)
2480             match = 0;
2481         else if (match > cCOP->uop.scop.scop_max)
2482             match = cCOP->uop.scop.scop_max;
2483         PL_op = cCOP->uop.scop.scop_next[match];
2484     }
2485     RETURNOP(PL_op);
2486 }
2487 #endif
2488
2489 /* Eval. */
2490
2491 STATIC void
2492 S_save_lines(pTHX_ AV *array, SV *sv)
2493 {
2494     register char *s = SvPVX(sv);
2495     register char *send = SvPVX(sv) + SvCUR(sv);
2496     register char *t;
2497     register I32 line = 1;
2498
2499     while (s && s < send) {
2500         SV *tmpstr = NEWSV(85,0);
2501
2502         sv_upgrade(tmpstr, SVt_PVMG);
2503         t = strchr(s, '\n');
2504         if (t)
2505             t++;
2506         else
2507             t = send;
2508
2509         sv_setpvn(tmpstr, s, t - s);
2510         av_store(array, line++, tmpstr);
2511         s = t;
2512     }
2513 }
2514
2515 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2516 STATIC void *
2517 S_docatch_body(pTHX_ va_list args)
2518 {
2519     return docatch_body();
2520 }
2521 #endif
2522
2523 STATIC void *
2524 S_docatch_body(pTHX)
2525 {
2526     CALLRUNOPS(aTHX);
2527     return NULL;
2528 }
2529
2530 STATIC OP *
2531 S_docatch(pTHX_ OP *o)
2532 {
2533     int ret;
2534     OP *oldop = PL_op;
2535     OP *retop;
2536     volatile PERL_SI *cursi = PL_curstackinfo;
2537     dJMPENV;
2538
2539 #ifdef DEBUGGING
2540     assert(CATCH_GET == TRUE);
2541 #endif
2542     PL_op = o;
2543
2544     /* Normally, the leavetry at the end of this block of ops will
2545      * pop an op off the return stack and continue there. By setting
2546      * the op to Nullop, we force an exit from the inner runops()
2547      * loop. DAPM.
2548      */
2549     retop = pop_return();
2550     push_return(Nullop);
2551
2552 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2553  redo_body:
2554     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2555 #else
2556     JMPENV_PUSH(ret);
2557 #endif
2558     switch (ret) {
2559     case 0:
2560 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2561  redo_body:
2562         docatch_body();
2563 #endif
2564         break;
2565     case 3:
2566         /* die caught by an inner eval - continue inner loop */
2567         if (PL_restartop && cursi == PL_curstackinfo) {
2568             PL_op = PL_restartop;
2569             PL_restartop = 0;
2570             goto redo_body;
2571         }
2572         /* a die in this eval - continue in outer loop */
2573         if (!PL_restartop)
2574             break;
2575         /* FALL THROUGH */
2576     default:
2577         JMPENV_POP;
2578         PL_op = oldop;
2579         JMPENV_JUMP(ret);
2580         /* NOTREACHED */
2581     }
2582     JMPENV_POP;
2583     PL_op = oldop;
2584     return retop;
2585 }
2586
2587 OP *
2588 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
2589 /* sv Text to convert to OP tree. */
2590 /* startop op_free() this to undo. */
2591 /* code Short string id of the caller. */
2592 {
2593     dSP;                                /* Make POPBLOCK work. */
2594     PERL_CONTEXT *cx;
2595     SV **newsp;
2596     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2597     I32 optype;
2598     OP dummy;
2599     OP *rop;
2600     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2601     char *tmpbuf = tbuf;
2602     char *safestr;
2603
2604     ENTER;
2605     lex_start(sv);
2606     SAVETMPS;
2607     /* switch to eval mode */
2608
2609     if (PL_curcop == &PL_compiling) {
2610         SAVECOPSTASH_FREE(&PL_compiling);
2611         CopSTASH_set(&PL_compiling, PL_curstash);
2612     }
2613     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2614         SV *sv = sv_newmortal();
2615         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2616                        code, (unsigned long)++PL_evalseq,
2617                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2618         tmpbuf = SvPVX(sv);
2619     }
2620     else
2621         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2622     SAVECOPFILE_FREE(&PL_compiling);
2623     CopFILE_set(&PL_compiling, tmpbuf+2);
2624     SAVECOPLINE(&PL_compiling);
2625     CopLINE_set(&PL_compiling, 1);
2626     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2627        deleting the eval's FILEGV from the stash before gv_check() runs
2628        (i.e. before run-time proper). To work around the coredump that
2629        ensues, we always turn GvMULTI_on for any globals that were
2630        introduced within evals. See force_ident(). GSAR 96-10-12 */
2631     safestr = savepv(tmpbuf);
2632     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2633     SAVEHINTS();
2634 #ifdef OP_IN_REGISTER
2635     PL_opsave = op;
2636 #else
2637     SAVEVPTR(PL_op);
2638 #endif
2639     PL_hints &= HINT_UTF8;
2640
2641     PL_op = &dummy;
2642     PL_op->op_type = OP_ENTEREVAL;
2643     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2644     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2645     PUSHEVAL(cx, 0, Nullgv);
2646     rop = doeval(G_SCALAR, startop);
2647     POPBLOCK(cx,PL_curpm);
2648     POPEVAL(cx);
2649
2650     (*startop)->op_type = OP_NULL;
2651     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2652     lex_end();
2653     *avp = (AV*)SvREFCNT_inc(PL_comppad);
2654     LEAVE;
2655     if (PL_curcop == &PL_compiling)
2656         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2657 #ifdef OP_IN_REGISTER
2658     op = PL_opsave;
2659 #endif
2660     return rop;
2661 }
2662
2663 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2664 STATIC OP *
2665 S_doeval(pTHX_ int gimme, OP** startop)
2666 {
2667     dSP;
2668     OP *saveop = PL_op;
2669     CV *caller;
2670     I32 i;
2671
2672     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2673                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2674                   : EVAL_INEVAL);
2675
2676     PUSHMARK(SP);
2677
2678     caller = PL_compcv;
2679     for (i = cxstack_ix - 1; i >= 0; i--) {
2680         PERL_CONTEXT *cx = &cxstack[i];
2681         if (CxTYPE(cx) == CXt_EVAL)
2682             break;
2683         else if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2684             caller = cx->blk_sub.cv;
2685             break;
2686         }
2687     }
2688
2689     SAVESPTR(PL_compcv);
2690     PL_compcv = (CV*)NEWSV(1104,0);
2691     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2692     CvEVAL_on(PL_compcv);
2693     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2694     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2695
2696 #ifdef USE_5005THREADS
2697     CvOWNER(PL_compcv) = 0;
2698     New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
2699     MUTEX_INIT(CvMUTEXP(PL_compcv));
2700 #endif /* USE_5005THREADS */
2701
2702     /* set up a scratch pad */
2703
2704     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2705
2706     if (!saveop ||
2707         (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
2708     {
2709         CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
2710     }
2711
2712     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2713
2714     /* make sure we compile in the right package */
2715
2716     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2717         SAVESPTR(PL_curstash);
2718         PL_curstash = CopSTASH(PL_curcop);
2719     }
2720     SAVESPTR(PL_beginav);
2721     PL_beginav = newAV();
2722     SAVEFREESV(PL_beginav);
2723     SAVEI32(PL_error_count);
2724
2725     /* try to compile it */
2726
2727     PL_eval_root = Nullop;
2728     PL_error_count = 0;
2729     PL_curcop = &PL_compiling;
2730     PL_curcop->cop_arybase = 0;
2731     if (saveop && saveop->op_flags & OPf_SPECIAL)
2732         PL_in_eval |= EVAL_KEEPERR;
2733     else
2734         sv_setpv(ERRSV,"");
2735     if (yyparse() || PL_error_count || !PL_eval_root) {
2736         SV **newsp;
2737         I32 gimme;
2738         PERL_CONTEXT *cx;
2739         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2740         STRLEN n_a;
2741
2742         PL_op = saveop;
2743         if (PL_eval_root) {
2744             op_free(PL_eval_root);
2745             PL_eval_root = Nullop;
2746         }
2747         SP = PL_stack_base + POPMARK;           /* pop original mark */
2748         if (!startop) {
2749             POPBLOCK(cx,PL_curpm);
2750             POPEVAL(cx);
2751             pop_return();
2752         }
2753         lex_end();
2754         LEAVE;
2755         if (optype == OP_REQUIRE) {
2756             char* msg = SvPVx(ERRSV, n_a);
2757             DIE(aTHX_ "%sCompilation failed in require",
2758                 *msg ? msg : "Unknown error\n");
2759         }
2760         else if (startop) {
2761             char* msg = SvPVx(ERRSV, n_a);
2762
2763             POPBLOCK(cx,PL_curpm);
2764             POPEVAL(cx);
2765             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2766                        (*msg ? msg : "Unknown error\n"));
2767         }
2768 #ifdef USE_5005THREADS
2769         MUTEX_LOCK(&PL_eval_mutex);
2770         PL_eval_owner = 0;
2771         COND_SIGNAL(&PL_eval_cond);
2772         MUTEX_UNLOCK(&PL_eval_mutex);
2773 #endif /* USE_5005THREADS */
2774         RETPUSHUNDEF;
2775     }
2776     CopLINE_set(&PL_compiling, 0);
2777     if (startop) {
2778         *startop = PL_eval_root;
2779         SvREFCNT_dec(CvOUTSIDE(PL_compcv));
2780         CvOUTSIDE(PL_compcv) = Nullcv;
2781     } else
2782         SAVEFREEOP(PL_eval_root);
2783     if (gimme & G_VOID)
2784         scalarvoid(PL_eval_root);
2785     else if (gimme & G_ARRAY)
2786         list(PL_eval_root);
2787     else
2788         scalar(PL_eval_root);
2789
2790     DEBUG_x(dump_eval());
2791
2792     /* Register with debugger: */
2793     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2794         CV *cv = get_cv("DB::postponed", FALSE);
2795         if (cv) {
2796             dSP;
2797             PUSHMARK(SP);
2798             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2799             PUTBACK;
2800             call_sv((SV*)cv, G_DISCARD);
2801         }
2802     }
2803
2804     /* compiled okay, so do it */
2805
2806     CvDEPTH(PL_compcv) = 1;
2807     SP = PL_stack_base + POPMARK;               /* pop original mark */
2808     PL_op = saveop;                     /* The caller may need it. */
2809     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2810 #ifdef USE_5005THREADS
2811     MUTEX_LOCK(&PL_eval_mutex);
2812     PL_eval_owner = 0;
2813     COND_SIGNAL(&PL_eval_cond);
2814     MUTEX_UNLOCK(&PL_eval_mutex);
2815 #endif /* USE_5005THREADS */
2816
2817     RETURNOP(PL_eval_start);
2818 }
2819
2820 STATIC PerlIO *
2821 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2822 {
2823     STRLEN namelen = strlen(name);
2824     PerlIO *fp;
2825
2826     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2827         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2828         char *pmc = SvPV_nolen(pmcsv);
2829         Stat_t pmstat;
2830         Stat_t pmcstat;
2831         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2832             fp = PerlIO_open(name, mode);
2833         }
2834         else {
2835             if (PerlLIO_stat(name, &pmstat) < 0 ||
2836                 pmstat.st_mtime < pmcstat.st_mtime)
2837             {
2838                 fp = PerlIO_open(pmc, mode);
2839             }
2840             else {
2841                 fp = PerlIO_open(name, mode);
2842             }
2843         }
2844         SvREFCNT_dec(pmcsv);
2845     }
2846     else {
2847         fp = PerlIO_open(name, mode);
2848     }
2849     return fp;
2850 }
2851
2852 PP(pp_require)
2853 {
2854     dSP;
2855     register PERL_CONTEXT *cx;
2856     SV *sv;
2857     char *name;
2858     STRLEN len;
2859     char *tryname = Nullch;
2860     SV *namesv = Nullsv;
2861     SV** svp;
2862     I32 gimme = GIMME_V;
2863     PerlIO *tryrsfp = 0;
2864     STRLEN n_a;
2865     int filter_has_file = 0;
2866     GV *filter_child_proc = 0;
2867     SV *filter_state = 0;
2868     SV *filter_sub = 0;
2869     SV *hook_sv = 0;
2870     SV *encoding;
2871     OP *op;
2872
2873     sv = POPs;
2874     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2875         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2876             UV rev = 0, ver = 0, sver = 0;
2877             STRLEN len;
2878             U8 *s = (U8*)SvPVX(sv);
2879             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2880             if (s < end) {
2881                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2882                 s += len;
2883                 if (s < end) {
2884                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
2885                     s += len;
2886                     if (s < end)
2887                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
2888                 }
2889             }
2890             if (PERL_REVISION < rev
2891                 || (PERL_REVISION == rev
2892                     && (PERL_VERSION < ver
2893                         || (PERL_VERSION == ver
2894                             && PERL_SUBVERSION < sver))))
2895             {
2896                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2897                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2898                     PERL_VERSION, PERL_SUBVERSION);
2899             }
2900             if (ckWARN(WARN_PORTABLE))
2901                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2902                         "v-string in use/require non-portable");
2903             RETPUSHYES;
2904         }
2905         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
2906             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2907                 + ((NV)PERL_SUBVERSION/(NV)1000000)
2908                 + 0.00000099 < SvNV(sv))
2909             {
2910                 NV nrev = SvNV(sv);
2911                 UV rev = (UV)nrev;
2912                 NV nver = (nrev - rev) * 1000;
2913                 UV ver = (UV)(nver + 0.0009);
2914                 NV nsver = (nver - ver) * 1000;
2915                 UV sver = (UV)(nsver + 0.0009);
2916
2917                 /* help out with the "use 5.6" confusion */
2918                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2919                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2920                         " (did you mean v%"UVuf".%03"UVuf"?)--"
2921                         "this is only v%d.%d.%d, stopped",
2922                         rev, ver, sver, rev, ver/100,
2923                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2924                 }
2925                 else {
2926                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2927                         "this is only v%d.%d.%d, stopped",
2928                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
2929                         PERL_SUBVERSION);
2930                 }
2931             }
2932             RETPUSHYES;
2933         }
2934     }
2935     name = SvPV(sv, len);
2936     if (!(name && len > 0 && *name))
2937         DIE(aTHX_ "Null filename used");
2938     TAINT_PROPER("require");
2939     if (PL_op->op_type == OP_REQUIRE &&
2940       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2941       *svp != &PL_sv_undef)
2942         RETPUSHYES;
2943
2944     /* prepare to compile file */
2945
2946     if (path_is_absolute(name)) {
2947         tryname = name;
2948         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2949     }
2950 #ifdef MACOS_TRADITIONAL
2951     if (!tryrsfp) {
2952         char newname[256];
2953
2954         MacPerl_CanonDir(name, newname, 1);
2955         if (path_is_absolute(newname)) {
2956             tryname = newname;
2957             tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2958         }
2959     }
2960 #endif
2961     if (!tryrsfp) {
2962         AV *ar = GvAVn(PL_incgv);
2963         I32 i;
2964 #ifdef VMS
2965         char *unixname;
2966         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2967 #endif
2968         {
2969             namesv = NEWSV(806, 0);
2970             for (i = 0; i <= AvFILL(ar); i++) {
2971                 SV *dirsv = *av_fetch(ar, i, TRUE);
2972
2973                 if (SvROK(dirsv)) {
2974                     int count;
2975                     SV *loader = dirsv;
2976
2977                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
2978                         && !sv_isobject(loader))
2979                     {
2980                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2981                     }
2982
2983                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2984                                    PTR2UV(SvRV(dirsv)), name);
2985                     tryname = SvPVX(namesv);
2986                     tryrsfp = 0;
2987
2988                     ENTER;
2989                     SAVETMPS;
2990                     EXTEND(SP, 2);
2991
2992                     PUSHMARK(SP);
2993                     PUSHs(dirsv);
2994                     PUSHs(sv);
2995                     PUTBACK;
2996                     if (sv_isobject(loader))
2997                         count = call_method("INC", G_ARRAY);
2998                     else
2999                         count = call_sv(loader, G_ARRAY);
3000                     SPAGAIN;
3001
3002                     if (count > 0) {
3003                         int i = 0;
3004                         SV *arg;
3005
3006                         SP -= count - 1;
3007                         arg = SP[i++];
3008
3009                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3010                             arg = SvRV(arg);
3011                         }
3012
3013                         if (SvTYPE(arg) == SVt_PVGV) {
3014                             IO *io = GvIO((GV *)arg);
3015
3016                             ++filter_has_file;
3017
3018                             if (io) {
3019                                 tryrsfp = IoIFP(io);
3020                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3021                                     /* reading from a child process doesn't
3022                                        nest -- when returning from reading
3023                                        the inner module, the outer one is
3024                                        unreadable (closed?)  I've tried to
3025                                        save the gv to manage the lifespan of
3026                                        the pipe, but this didn't help. XXX */
3027                                     filter_child_proc = (GV *)arg;
3028                                     (void)SvREFCNT_inc(filter_child_proc);
3029                                 }
3030                                 else {
3031                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3032                                         PerlIO_close(IoOFP(io));
3033                                     }
3034                                     IoIFP(io) = Nullfp;
3035                                     IoOFP(io) = Nullfp;
3036                                 }
3037                             }
3038
3039                             if (i < count) {
3040                                 arg = SP[i++];
3041                             }
3042                         }
3043
3044                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3045                             filter_sub = arg;
3046                             (void)SvREFCNT_inc(filter_sub);
3047
3048                             if (i < count) {
3049                                 filter_state = SP[i];
3050                                 (void)SvREFCNT_inc(filter_state);
3051                             }
3052
3053                             if (tryrsfp == 0) {
3054                                 tryrsfp = PerlIO_open("/dev/null",
3055                                                       PERL_SCRIPT_MODE);
3056                             }
3057                         }
3058                     }
3059
3060                     PUTBACK;
3061                     FREETMPS;
3062                     LEAVE;
3063
3064                     if (tryrsfp) {
3065                         hook_sv = dirsv;
3066                         break;
3067                     }
3068
3069                     filter_has_file = 0;
3070                     if (filter_child_proc) {
3071                         SvREFCNT_dec(filter_child_proc);
3072                         filter_child_proc = 0;
3073                     }
3074                     if (filter_state) {
3075                         SvREFCNT_dec(filter_state);
3076                         filter_state = 0;
3077                     }
3078                     if (filter_sub) {
3079                         SvREFCNT_dec(filter_sub);
3080                         filter_sub = 0;
3081                     }
3082                 }
3083                 else {
3084                   if (!path_is_absolute(name)
3085 #ifdef MACOS_TRADITIONAL
3086                         /* We consider paths of the form :a:b ambiguous and interpret them first
3087                            as global then as local
3088                         */
3089                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3090 #endif
3091                   ) {
3092                     char *dir = SvPVx(dirsv, n_a);
3093 #ifdef MACOS_TRADITIONAL
3094                     char buf1[256];
3095                     char buf2[256];
3096
3097                     MacPerl_CanonDir(name, buf2, 1);
3098                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3099 #else
3100 #ifdef VMS
3101                     char *unixdir;
3102                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3103                         continue;
3104                     sv_setpv(namesv, unixdir);
3105                     sv_catpv(namesv, unixname);
3106 #else
3107                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3108 #endif
3109 #endif
3110                     TAINT_PROPER("require");
3111                     tryname = SvPVX(namesv);
3112                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3113                     if (tryrsfp) {
3114                         if (tryname[0] == '.' && tryname[1] == '/')
3115                             tryname += 2;
3116                         break;
3117                     }
3118                   }
3119                 }
3120             }
3121         }
3122     }
3123     SAVECOPFILE_FREE(&PL_compiling);
3124     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3125     SvREFCNT_dec(namesv);
3126     if (!tryrsfp) {
3127         if (PL_op->op_type == OP_REQUIRE) {
3128             char *msgstr = name;
3129             if (namesv) {                       /* did we lookup @INC? */
3130                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3131                 SV *dirmsgsv = NEWSV(0, 0);
3132                 AV *ar = GvAVn(PL_incgv);
3133                 I32 i;
3134                 sv_catpvn(msg, " in @INC", 8);
3135                 if (instr(SvPVX(msg), ".h "))
3136                     sv_catpv(msg, " (change .h to .ph maybe?)");
3137                 if (instr(SvPVX(msg), ".ph "))
3138                     sv_catpv(msg, " (did you run h2ph?)");
3139                 sv_catpv(msg, " (@INC contains:");
3140                 for (i = 0; i <= AvFILL(ar); i++) {
3141                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3142                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3143                     sv_catsv(msg, dirmsgsv);
3144                 }
3145                 sv_catpvn(msg, ")", 1);
3146                 SvREFCNT_dec(dirmsgsv);
3147                 msgstr = SvPV_nolen(msg);
3148             }
3149             DIE(aTHX_ "Can't locate %s", msgstr);
3150         }
3151
3152         RETPUSHUNDEF;
3153     }
3154     else
3155         SETERRNO(0, SS_NORMAL);
3156
3157     /* Assume success here to prevent recursive requirement. */
3158     len = strlen(name);
3159     /* Check whether a hook in @INC has already filled %INC */
3160     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3161         (void)hv_store(GvHVn(PL_incgv), name, len,
3162                        (hook_sv ? SvREFCNT_inc(hook_sv)
3163                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3164                        0 );
3165     }
3166
3167     ENTER;
3168     SAVETMPS;
3169     lex_start(sv_2mortal(newSVpvn("",0)));
3170     SAVEGENERICSV(PL_rsfp_filters);
3171     PL_rsfp_filters = Nullav;
3172
3173     PL_rsfp = tryrsfp;
3174     SAVEHINTS();
3175     PL_hints = 0;
3176     SAVESPTR(PL_compiling.cop_warnings);
3177     if (PL_dowarn & G_WARN_ALL_ON)
3178         PL_compiling.cop_warnings = pWARN_ALL ;
3179     else if (PL_dowarn & G_WARN_ALL_OFF)
3180         PL_compiling.cop_warnings = pWARN_NONE ;
3181     else if (PL_taint_warn)
3182         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3183     else
3184         PL_compiling.cop_warnings = pWARN_STD ;
3185     SAVESPTR(PL_compiling.cop_io);
3186     PL_compiling.cop_io = Nullsv;
3187
3188     if (filter_sub || filter_child_proc) {
3189         SV *datasv = filter_add(run_user_filter, Nullsv);
3190         IoLINES(datasv) = filter_has_file;
3191         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3192         IoTOP_GV(datasv) = (GV *)filter_state;
3193         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3194     }
3195
3196     /* switch to eval mode */
3197     push_return(PL_op->op_next);
3198     PUSHBLOCK(cx, CXt_EVAL, SP);
3199     PUSHEVAL(cx, name, Nullgv);
3200
3201     SAVECOPLINE(&PL_compiling);
3202     CopLINE_set(&PL_compiling, 0);
3203
3204     PUTBACK;
3205 #ifdef USE_5005THREADS
3206     MUTEX_LOCK(&PL_eval_mutex);
3207     if (PL_eval_owner && PL_eval_owner != thr)
3208         while (PL_eval_owner)
3209             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3210     PL_eval_owner = thr;
3211     MUTEX_UNLOCK(&PL_eval_mutex);
3212 #endif /* USE_5005THREADS */
3213
3214     /* Store and reset encoding. */
3215     encoding = PL_encoding;
3216     PL_encoding = Nullsv;
3217
3218     op = DOCATCH(doeval(gimme, NULL));
3219
3220     /* Restore encoding. */
3221     PL_encoding = encoding;
3222
3223     return op;
3224 }
3225
3226 PP(pp_dofile)
3227 {
3228     return pp_require();
3229 }
3230
3231 PP(pp_entereval)
3232 {
3233     dSP;
3234     register PERL_CONTEXT *cx;
3235     dPOPss;
3236     I32 gimme = GIMME_V, was = PL_sub_generation;
3237     char tbuf[TYPE_DIGITS(long) + 12];
3238     char *tmpbuf = tbuf;
3239     char *safestr;
3240     STRLEN len;
3241     OP *ret;
3242
3243     if (!SvPV(sv,len))
3244         RETPUSHUNDEF;
3245     TAINT_PROPER("eval");
3246
3247     ENTER;
3248     lex_start(sv);
3249     SAVETMPS;
3250
3251     /* switch to eval mode */
3252
3253     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3254         SV *sv = sv_newmortal();
3255         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3256                        (unsigned long)++PL_evalseq,
3257                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3258         tmpbuf = SvPVX(sv);
3259     }
3260     else
3261         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3262     SAVECOPFILE_FREE(&PL_compiling);
3263     CopFILE_set(&PL_compiling, tmpbuf+2);
3264     SAVECOPLINE(&PL_compiling);
3265     CopLINE_set(&PL_compiling, 1);
3266     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3267        deleting the eval's FILEGV from the stash before gv_check() runs
3268        (i.e. before run-time proper). To work around the coredump that
3269        ensues, we always turn GvMULTI_on for any globals that were
3270        introduced within evals. See force_ident(). GSAR 96-10-12 */
3271     safestr = savepv(tmpbuf);
3272     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3273     SAVEHINTS();
3274     PL_hints = PL_op->op_targ;
3275     SAVESPTR(PL_compiling.cop_warnings);
3276     if (specialWARN(PL_curcop->cop_warnings))
3277         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3278     else {
3279         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3280         SAVEFREESV(PL_compiling.cop_warnings);
3281     }
3282     SAVESPTR(PL_compiling.cop_io);
3283     if (specialCopIO(PL_curcop->cop_io))
3284         PL_compiling.cop_io = PL_curcop->cop_io;
3285     else {
3286         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3287         SAVEFREESV(PL_compiling.cop_io);
3288     }
3289
3290     push_return(PL_op->op_next);
3291     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3292     PUSHEVAL(cx, 0, Nullgv);
3293
3294     /* prepare to compile string */
3295
3296     if (PERLDB_LINE && PL_curstash != PL_debstash)
3297         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3298     PUTBACK;
3299 #ifdef USE_5005THREADS
3300     MUTEX_LOCK(&PL_eval_mutex);
3301     if (PL_eval_owner && PL_eval_owner != thr)
3302         while (PL_eval_owner)
3303             COND_WAIT(&PL_eval_cond, &PL_eval_mutex);
3304     PL_eval_owner = thr;
3305     MUTEX_UNLOCK(&PL_eval_mutex);
3306 #endif /* USE_5005THREADS */
3307     ret = doeval(gimme, NULL);
3308     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3309         && ret != PL_op->op_next) {     /* Successive compilation. */
3310         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3311     }
3312     return DOCATCH(ret);
3313 }
3314
3315 PP(pp_leaveeval)
3316 {
3317     dSP;
3318     register SV **mark;
3319     SV **newsp;
3320     PMOP *newpm;
3321     I32 gimme;
3322     register PERL_CONTEXT *cx;
3323     OP *retop;
3324     U8 save_flags = PL_op -> op_flags;
3325     I32 optype;
3326
3327     POPBLOCK(cx,newpm);
3328     POPEVAL(cx);
3329     retop = pop_return();
3330
3331     TAINT_NOT;
3332     if (gimme == G_VOID)
3333         MARK = newsp;
3334     else if (gimme == G_SCALAR) {
3335         MARK = newsp + 1;
3336         if (MARK <= SP) {
3337             if (SvFLAGS(TOPs) & SVs_TEMP)
3338                 *MARK = TOPs;
3339             else
3340                 *MARK = sv_mortalcopy(TOPs);
3341         }
3342         else {
3343             MEXTEND(mark,0);
3344             *MARK = &PL_sv_undef;
3345         }
3346         SP = MARK;
3347     }
3348     else {
3349         /* in case LEAVE wipes old return values */
3350         for (mark = newsp + 1; mark <= SP; mark++) {
3351             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3352                 *mark = sv_mortalcopy(*mark);
3353                 TAINT_NOT;      /* Each item is independent */
3354             }
3355         }
3356     }
3357     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3358
3359 #ifdef DEBUGGING
3360     assert(CvDEPTH(PL_compcv) == 1);
3361 #endif
3362     CvDEPTH(PL_compcv) = 0;
3363     lex_end();
3364
3365     if (optype == OP_REQUIRE &&
3366         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3367     {
3368         /* Unassume the success we assumed earlier. */
3369         SV *nsv = cx->blk_eval.old_namesv;
3370         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3371         retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3372         /* die_where() did LEAVE, or we won't be here */
3373     }
3374     else {
3375         LEAVE;
3376         if (!(save_flags & OPf_SPECIAL))
3377             sv_setpv(ERRSV,"");
3378     }
3379
3380     RETURNOP(retop);
3381 }
3382
3383 PP(pp_entertry)
3384 {
3385     dSP;
3386     register PERL_CONTEXT *cx;
3387     I32 gimme = GIMME_V;
3388
3389     ENTER;
3390     SAVETMPS;
3391
3392     push_return(cLOGOP->op_other->op_next);
3393     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3394     PUSHEVAL(cx, 0, 0);
3395
3396     PL_in_eval = EVAL_INEVAL;
3397     sv_setpv(ERRSV,"");
3398     PUTBACK;
3399     return DOCATCH(PL_op->op_next);
3400 }
3401
3402 PP(pp_leavetry)
3403 {
3404     dSP;
3405     register SV **mark;
3406     SV **newsp;
3407     PMOP *newpm;
3408     OP* retop;
3409     I32 gimme;
3410     register PERL_CONTEXT *cx;
3411     I32 optype;
3412
3413     POPBLOCK(cx,newpm);
3414     POPEVAL(cx);
3415     retop = pop_return();
3416
3417     TAINT_NOT;
3418     if (gimme == G_VOID)
3419         SP = newsp;
3420     else if (gimme == G_SCALAR) {
3421         MARK = newsp + 1;
3422         if (MARK <= SP) {
3423             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3424                 *MARK = TOPs;
3425             else
3426                 *MARK = sv_mortalcopy(TOPs);
3427         }
3428         else {
3429             MEXTEND(mark,0);
3430             *MARK = &PL_sv_undef;
3431         }
3432         SP = MARK;
3433     }
3434     else {
3435         /* in case LEAVE wipes old return values */
3436         for (mark = newsp + 1; mark <= SP; mark++) {
3437             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3438                 *mark = sv_mortalcopy(*mark);
3439                 TAINT_NOT;      /* Each item is independent */
3440             }
3441         }
3442     }
3443     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3444
3445     LEAVE;
3446     sv_setpv(ERRSV,"");
3447     RETURNOP(retop);
3448 }
3449
3450 STATIC void
3451 S_doparseform(pTHX_ SV *sv)
3452 {
3453     STRLEN len;
3454     register char *s = SvPV_force(sv, len);
3455     register char *send = s + len;
3456     register char *base = Nullch;
3457     register I32 skipspaces = 0;
3458     bool noblank   = FALSE;
3459     bool repeat    = FALSE;
3460     bool postspace = FALSE;
3461     U16 *fops;
3462     register U16 *fpc;
3463     U16 *linepc = 0;
3464     register I32 arg;
3465     bool ischop;
3466
3467     if (len == 0)
3468         Perl_croak(aTHX_ "Null picture in formline");
3469
3470     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3471     fpc = fops;
3472
3473     if (s < send) {
3474         linepc = fpc;
3475         *fpc++ = FF_LINEMARK;
3476         noblank = repeat = FALSE;
3477         base = s;
3478     }
3479
3480     while (s <= send) {
3481         switch (*s++) {
3482         default:
3483             skipspaces = 0;
3484             continue;
3485
3486         case '~':
3487             if (*s == '~') {
3488                 repeat = TRUE;
3489                 *s = ' ';
3490             }
3491             noblank = TRUE;
3492             s[-1] = ' ';
3493             /* FALL THROUGH */
3494         case ' ': case '\t':
3495             skipspaces++;
3496             continue;
3497
3498         case '\n': case 0:
3499             arg = s - base;
3500             skipspaces++;
3501             arg -= skipspaces;
3502             if (arg) {
3503                 if (postspace)
3504                     *fpc++ = FF_SPACE;
3505                 *fpc++ = FF_LITERAL;
3506                 *fpc++ = (U16)arg;
3507             }
3508             postspace = FALSE;
3509             if (s <= send)
3510                 skipspaces--;
3511             if (skipspaces) {
3512                 *fpc++ = FF_SKIP;
3513                 *fpc++ = (U16)skipspaces;
3514             }
3515             skipspaces = 0;
3516             if (s <= send)
3517                 *fpc++ = FF_NEWLINE;
3518             if (noblank) {
3519                 *fpc++ = FF_BLANK;
3520                 if (repeat)
3521                     arg = fpc - linepc + 1;
3522                 else
3523                     arg = 0;
3524                 *fpc++ = (U16)arg;
3525             }
3526             if (s < send) {
3527                 linepc = fpc;
3528                 *fpc++ = FF_LINEMARK;
3529                 noblank = repeat = FALSE;
3530                 base = s;
3531             }
3532             else
3533                 s++;
3534             continue;
3535
3536         case '@':
3537         case '^':
3538             ischop = s[-1] == '^';
3539
3540             if (postspace) {
3541                 *fpc++ = FF_SPACE;
3542                 postspace = FALSE;
3543             }
3544             arg = (s - base) - 1;
3545             if (arg) {
3546                 *fpc++ = FF_LITERAL;
3547                 *fpc++ = (U16)arg;
3548             }
3549
3550             base = s - 1;
3551             *fpc++ = FF_FETCH;
3552             if (*s == '*') {
3553                 s++;
3554                 *fpc++ = 0;
3555                 *fpc++ = FF_LINEGLOB;
3556             }
3557             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3558                 arg = ischop ? 512 : 0;
3559                 base = s - 1;
3560                 while (*s == '#')
3561                     s++;
3562                 if (*s == '.') {
3563                     char *f;
3564                     s++;
3565                     f = s;
3566                     while (*s == '#')
3567                         s++;
3568                     arg |= 256 + (s - f);
3569                 }
3570                 *fpc++ = s - base;              /* fieldsize for FETCH */
3571                 *fpc++ = FF_DECIMAL;
3572                 *fpc++ = (U16)arg;
3573             }
3574             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3575                 arg = ischop ? 512 : 0;
3576                 base = s - 1;
3577                 s++;                                /* skip the '0' first */
3578                 while (*s == '#')
3579                     s++;
3580                 if (*s == '.') {
3581                     char *f;
3582                     s++;
3583                     f = s;
3584                     while (*s == '#')
3585                         s++;
3586                     arg |= 256 + (s - f);
3587                 }
3588                 *fpc++ = s - base;                /* fieldsize for FETCH */
3589                 *fpc++ = FF_0DECIMAL;
3590                 *fpc++ = (U16)arg;
3591             }
3592             else {
3593                 I32 prespace = 0;
3594                 bool ismore = FALSE;
3595
3596                 if (*s == '>') {
3597                     while (*++s == '>') ;
3598                     prespace = FF_SPACE;
3599                 }
3600                 else if (*s == '|') {
3601                     while (*++s == '|') ;
3602                     prespace = FF_HALFSPACE;
3603                     postspace = TRUE;
3604                 }
3605                 else {
3606                     if (*s == '<')
3607                         while (*++s == '<') ;
3608                     postspace = TRUE;
3609                 }
3610                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3611                     s += 3;
3612                     ismore = TRUE;
3613                 }
3614                 *fpc++ = s - base;              /* fieldsize for FETCH */
3615
3616                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3617
3618                 if (prespace)
3619                     *fpc++ = (U16)prespace;
3620                 *fpc++ = FF_ITEM;
3621                 if (ismore)
3622                     *fpc++ = FF_MORE;
3623                 if (ischop)
3624                     *fpc++ = FF_CHOP;
3625             }
3626             base = s;
3627             skipspaces = 0;
3628             continue;
3629         }
3630     }
3631     *fpc++ = FF_END;
3632
3633     arg = fpc - fops;
3634     { /* need to jump to the next word */
3635         int z;
3636         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3637         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3638         s = SvPVX(sv) + SvCUR(sv) + z;
3639     }
3640     Copy(fops, s, arg, U16);
3641     Safefree(fops);
3642     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3643     SvCOMPILED_on(sv);
3644 }
3645
3646 static I32
3647 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3648 {
3649     SV *datasv = FILTER_DATA(idx);
3650     int filter_has_file = IoLINES(datasv);
3651     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3652     SV *filter_state = (SV *)IoTOP_GV(datasv);
3653     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3654     int len = 0;
3655
3656     /* I was having segfault trouble under Linux 2.2.5 after a
3657        parse error occured.  (Had to hack around it with a test
3658        for PL_error_count == 0.)  Solaris doesn't segfault --
3659        not sure where the trouble is yet.  XXX */
3660
3661     if (filter_has_file) {
3662         len = FILTER_READ(idx+1, buf_sv, maxlen);
3663     }
3664
3665     if (filter_sub && len >= 0) {
3666         dSP;
3667         int count;
3668
3669         ENTER;
3670         SAVE_DEFSV;
3671         SAVETMPS;
3672         EXTEND(SP, 2);
3673
3674         DEFSV = buf_sv;
3675         PUSHMARK(SP);
3676         PUSHs(sv_2mortal(newSViv(maxlen)));
3677         if (filter_state) {
3678             PUSHs(filter_state);
3679         }
3680         PUTBACK;
3681         count = call_sv(filter_sub, G_SCALAR);
3682         SPAGAIN;
3683
3684         if (count > 0) {
3685             SV *out = POPs;
3686             if (SvOK(out)) {
3687                 len = SvIV(out);
3688             }
3689         }
3690
3691         PUTBACK;
3692         FREETMPS;
3693         LEAVE;
3694     }
3695
3696     if (len <= 0) {
3697         IoLINES(datasv) = 0;
3698         if (filter_child_proc) {
3699             SvREFCNT_dec(filter_child_proc);
3700             IoFMT_GV(datasv) = Nullgv;
3701         }
3702         if (filter_state) {
3703             SvREFCNT_dec(filter_state);
3704             IoTOP_GV(datasv) = Nullgv;
3705         }
3706         if (filter_sub) {
3707             SvREFCNT_dec(filter_sub);
3708             IoBOTTOM_GV(datasv) = Nullgv;
3709         }
3710         filter_del(run_user_filter);
3711     }
3712
3713     return len;
3714 }
3715
3716 /* perhaps someone can come up with a better name for
3717    this?  it is not really "absolute", per se ... */
3718 static bool
3719 S_path_is_absolute(pTHX_ char *name)
3720 {
3721     if (PERL_FILE_IS_ABSOLUTE(name)
3722 #ifdef MACOS_TRADITIONAL
3723         || (*name == ':'))
3724 #else
3725         || (*name == '.' && (name[1] == '/' ||
3726                              (name[1] == '.' && name[2] == '/'))))
3727 #endif
3728     {
3729         return TRUE;
3730     }
3731     else
3732         return FALSE;
3733 }