pp_ctl.c

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