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