pp_ctl.c

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