pp_ctl.c

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