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