pp_ctl.c

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