pp_ctl.c

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