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
1369         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1370                && PL_curstackinfo->si_prev)
1371         {
1372             dounwind(-1);
1373             POPSTACK;
1374         }
1375
1376         if (cxix >= 0) {
1377             I32 optype;
1378
1379             if (cxix < cxstack_ix)
1380                 dounwind(cxix);
1381
1382             POPBLOCK(cx,PL_curpm);
1383             if (CxTYPE(cx) != CXt_EVAL) {
1384                 if (!message)
1385                     message = SvPVx(ERRSV, msglen);
1386                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1387                 PerlIO_write(Perl_error_log, message, msglen);
1388                 my_exit(1);
1389             }
1390             POPEVAL(cx);
1391
1392             if (gimme == G_SCALAR)
1393                 *++newsp = &PL_sv_undef;
1394             PL_stack_sp = newsp;
1395
1396             LEAVE;
1397
1398             /* LEAVE could clobber PL_curcop (see save_re_context())
1399              * XXX it might be better to find a way to avoid messing with
1400              * PL_curcop in save_re_context() instead, but this is a more
1401              * minimal fix --GSAR */
1402             PL_curcop = cx->blk_oldcop;
1403
1404             if (optype == OP_REQUIRE) {
1405                 char* msg = SvPVx(ERRSV, n_a);
1406                 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)
2902         scalarvoid(PL_eval_root);
2903     else if (gimme & G_ARRAY)
2904         list(PL_eval_root);
2905     else
2906         scalar(PL_eval_root);
2907
2908     DEBUG_x(dump_eval());
2909
2910     /* Register with debugger: */
2911     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2912         CV *cv = get_cv("DB::postponed", FALSE);
2913         if (cv) {
2914             dSP;
2915             PUSHMARK(SP);
2916             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2917             PUTBACK;
2918             call_sv((SV*)cv, G_DISCARD);
2919         }
2920     }
2921
2922     /* compiled okay, so do it */
2923
2924     CvDEPTH(PL_compcv) = 1;
2925     SP = PL_stack_base + POPMARK;               /* pop original mark */
2926     PL_op = saveop;                     /* The caller may need it. */
2927     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2928
2929     RETURNOP(PL_eval_start);
2930 }
2931
2932 STATIC PerlIO *
2933 S_doopen_pm(pTHX_ const char *name, const char *mode)
2934 {
2935 #ifndef PERL_DISABLE_PMC
2936     STRLEN namelen = strlen(name);
2937     PerlIO *fp;
2938
2939     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2940         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2941         char *pmc = SvPV_nolen(pmcsv);
2942         Stat_t pmstat;
2943         Stat_t pmcstat;
2944         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2945             fp = PerlIO_open(name, mode);
2946         }
2947         else {
2948             if (PerlLIO_stat(name, &pmstat) < 0 ||
2949                 pmstat.st_mtime < pmcstat.st_mtime)
2950             {
2951                 fp = PerlIO_open(pmc, mode);
2952             }
2953             else {
2954                 fp = PerlIO_open(name, mode);
2955             }
2956         }
2957         SvREFCNT_dec(pmcsv);
2958     }
2959     else {
2960         fp = PerlIO_open(name, mode);
2961     }
2962     return fp;
2963 #else
2964     return PerlIO_open(name, mode);
2965 #endif /* !PERL_DISABLE_PMC */
2966 }
2967
2968 PP(pp_require)
2969 {
2970     dSP;
2971     register PERL_CONTEXT *cx;
2972     SV *sv;
2973     char *name;
2974     STRLEN len;
2975     char *tryname = Nullch;
2976     SV *namesv = Nullsv;
2977     SV** svp;
2978     I32 gimme = GIMME_V;
2979     PerlIO *tryrsfp = 0;
2980     STRLEN n_a;
2981     int filter_has_file = 0;
2982     GV *filter_child_proc = 0;
2983     SV *filter_state = 0;
2984     SV *filter_sub = 0;
2985     SV *hook_sv = 0;
2986     SV *encoding;
2987     OP *op;
2988
2989     sv = POPs;
2990     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2991         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2992             UV rev = 0, ver = 0, sver = 0;
2993             STRLEN len;
2994             U8 *s = (U8*)SvPVX(sv);
2995             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2996             if (s < end) {
2997                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2998                 s += len;
2999                 if (s < end) {
3000                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
3001                     s += len;
3002                     if (s < end)
3003                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
3004                 }
3005             }
3006             if (PERL_REVISION < rev
3007                 || (PERL_REVISION == rev
3008                     && (PERL_VERSION < ver
3009                         || (PERL_VERSION == ver
3010                             && PERL_SUBVERSION < sver))))
3011             {
3012                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3013                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3014                     PERL_VERSION, PERL_SUBVERSION);
3015             }
3016             if (ckWARN(WARN_PORTABLE))
3017                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3018                         "v-string in use/require non-portable");
3019             RETPUSHYES;
3020         }
3021         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3022             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3023                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3024                 + 0.00000099 < SvNV(sv))
3025             {
3026                 NV nrev = SvNV(sv);
3027                 UV rev = (UV)nrev;
3028                 NV nver = (nrev - rev) * 1000;
3029                 UV ver = (UV)(nver + 0.0009);
3030                 NV nsver = (nver - ver) * 1000;
3031                 UV sver = (UV)(nsver + 0.0009);
3032
3033                 /* help out with the "use 5.6" confusion */
3034                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3035                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3036                         " (did you mean v%"UVuf".%03"UVuf"?)--"
3037                         "this is only v%d.%d.%d, stopped",
3038                         rev, ver, sver, rev, ver/100,
3039                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3040                 }
3041                 else {
3042                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3043                         "this is only v%d.%d.%d, stopped",
3044                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3045                         PERL_SUBVERSION);
3046                 }
3047             }
3048             RETPUSHYES;
3049         }
3050     }
3051     name = SvPV(sv, len);
3052     if (!(name && len > 0 && *name))
3053         DIE(aTHX_ "Null filename used");
3054     TAINT_PROPER("require");
3055     if (PL_op->op_type == OP_REQUIRE &&
3056       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3057       *svp != &PL_sv_undef)
3058         RETPUSHYES;
3059
3060     /* prepare to compile file */
3061
3062     if (path_is_absolute(name)) {
3063         tryname = name;
3064         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3065     }
3066 #ifdef MACOS_TRADITIONAL
3067     if (!tryrsfp) {
3068         char newname[256];
3069
3070         MacPerl_CanonDir(name, newname, 1);
3071         if (path_is_absolute(newname)) {
3072             tryname = newname;
3073             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3074         }
3075     }
3076 #endif
3077     if (!tryrsfp) {
3078         AV *ar = GvAVn(PL_incgv);
3079         I32 i;
3080 #ifdef VMS
3081         char *unixname;
3082         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3083 #endif
3084         {
3085             namesv = NEWSV(806, 0);
3086             for (i = 0; i <= AvFILL(ar); i++) {
3087                 SV *dirsv = *av_fetch(ar, i, TRUE);
3088
3089                 if (SvROK(dirsv)) {
3090                     int count;
3091                     SV *loader = dirsv;
3092
3093                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3094                         && !sv_isobject(loader))
3095                     {
3096                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3097                     }
3098
3099                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3100                                    PTR2UV(SvRV(dirsv)), name);
3101                     tryname = SvPVX(namesv);
3102                     tryrsfp = 0;
3103
3104                     ENTER;
3105                     SAVETMPS;
3106                     EXTEND(SP, 2);
3107
3108                     PUSHMARK(SP);
3109                     PUSHs(dirsv);
3110                     PUSHs(sv);
3111                     PUTBACK;
3112                     if (sv_isobject(loader))
3113                         count = call_method("INC", G_ARRAY);
3114                     else
3115                         count = call_sv(loader, G_ARRAY);
3116                     SPAGAIN;
3117
3118                     if (count > 0) {
3119                         int i = 0;
3120                         SV *arg;
3121
3122                         SP -= count - 1;
3123                         arg = SP[i++];
3124
3125                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3126                             arg = SvRV(arg);
3127                         }
3128
3129                         if (SvTYPE(arg) == SVt_PVGV) {
3130                             IO *io = GvIO((GV *)arg);
3131
3132                             ++filter_has_file;
3133
3134                             if (io) {
3135                                 tryrsfp = IoIFP(io);
3136                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3137                                     /* reading from a child process doesn't
3138                                        nest -- when returning from reading
3139                                        the inner module, the outer one is
3140                                        unreadable (closed?)  I've tried to
3141                                        save the gv to manage the lifespan of
3142                                        the pipe, but this didn't help. XXX */
3143                                     filter_child_proc = (GV *)arg;
3144                                     (void)SvREFCNT_inc(filter_child_proc);
3145                                 }
3146                                 else {
3147                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3148                                         PerlIO_close(IoOFP(io));
3149                                     }
3150                                     IoIFP(io) = Nullfp;
3151                                     IoOFP(io) = Nullfp;
3152                                 }
3153                             }
3154
3155                             if (i < count) {
3156                                 arg = SP[i++];
3157                             }
3158                         }
3159
3160                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3161                             filter_sub = arg;
3162                             (void)SvREFCNT_inc(filter_sub);
3163
3164                             if (i < count) {
3165                                 filter_state = SP[i];
3166                                 (void)SvREFCNT_inc(filter_state);
3167                             }
3168
3169                             if (tryrsfp == 0) {
3170                                 tryrsfp = PerlIO_open("/dev/null",
3171                                                       PERL_SCRIPT_MODE);
3172                             }
3173                         }
3174                     }
3175
3176                     PUTBACK;
3177                     FREETMPS;
3178                     LEAVE;
3179
3180                     if (tryrsfp) {
3181                         hook_sv = dirsv;
3182                         break;
3183                     }
3184
3185                     filter_has_file = 0;
3186                     if (filter_child_proc) {
3187                         SvREFCNT_dec(filter_child_proc);
3188                         filter_child_proc = 0;
3189                     }
3190                     if (filter_state) {
3191                         SvREFCNT_dec(filter_state);
3192                         filter_state = 0;
3193                     }
3194                     if (filter_sub) {
3195                         SvREFCNT_dec(filter_sub);
3196                         filter_sub = 0;
3197                     }
3198                 }
3199                 else {
3200                   if (!path_is_absolute(name)
3201 #ifdef MACOS_TRADITIONAL
3202                         /* We consider paths of the form :a:b ambiguous and interpret them first
3203                            as global then as local
3204                         */
3205                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3206 #endif
3207                   ) {
3208                     char *dir = SvPVx(dirsv, n_a);
3209 #ifdef MACOS_TRADITIONAL
3210                     char buf1[256];
3211                     char buf2[256];
3212
3213                     MacPerl_CanonDir(name, buf2, 1);
3214                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3215 #else
3216 #ifdef VMS
3217                     char *unixdir;
3218                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3219                         continue;
3220                     sv_setpv(namesv, unixdir);
3221                     sv_catpv(namesv, unixname);
3222 #else
3223                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3224 #endif
3225 #endif
3226                     TAINT_PROPER("require");
3227                     tryname = SvPVX(namesv);
3228                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3229                     if (tryrsfp) {
3230                         if (tryname[0] == '.' && tryname[1] == '/')
3231                             tryname += 2;
3232                         break;
3233                     }
3234                   }
3235                 }
3236             }
3237         }
3238     }
3239     SAVECOPFILE_FREE(&PL_compiling);
3240     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3241     SvREFCNT_dec(namesv);
3242     if (!tryrsfp) {
3243         if (PL_op->op_type == OP_REQUIRE) {
3244             char *msgstr = name;
3245             if (namesv) {                       /* did we lookup @INC? */
3246                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3247                 SV *dirmsgsv = NEWSV(0, 0);
3248                 AV *ar = GvAVn(PL_incgv);
3249                 I32 i;
3250                 sv_catpvn(msg, " in @INC", 8);
3251                 if (instr(SvPVX(msg), ".h "))
3252                     sv_catpv(msg, " (change .h to .ph maybe?)");
3253                 if (instr(SvPVX(msg), ".ph "))
3254                     sv_catpv(msg, " (did you run h2ph?)");
3255                 sv_catpv(msg, " (@INC contains:");
3256                 for (i = 0; i <= AvFILL(ar); i++) {
3257                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3258                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3259                     sv_catsv(msg, dirmsgsv);
3260                 }
3261                 sv_catpvn(msg, ")", 1);
3262                 SvREFCNT_dec(dirmsgsv);
3263                 msgstr = SvPV_nolen(msg);
3264             }
3265             DIE(aTHX_ "Can't locate %s", msgstr);
3266         }
3267
3268         RETPUSHUNDEF;
3269     }
3270     else
3271         SETERRNO(0, SS_NORMAL);
3272
3273     /* Assume success here to prevent recursive requirement. */
3274     len = strlen(name);
3275     /* Check whether a hook in @INC has already filled %INC */
3276     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3277         (void)hv_store(GvHVn(PL_incgv), name, len,
3278                        (hook_sv ? SvREFCNT_inc(hook_sv)
3279                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3280                        0 );
3281     }
3282
3283     ENTER;
3284     SAVETMPS;
3285     lex_start(sv_2mortal(newSVpvn("",0)));
3286     SAVEGENERICSV(PL_rsfp_filters);
3287     PL_rsfp_filters = Nullav;
3288
3289     PL_rsfp = tryrsfp;
3290     SAVEHINTS();
3291     PL_hints = 0;
3292     SAVESPTR(PL_compiling.cop_warnings);
3293     if (PL_dowarn & G_WARN_ALL_ON)
3294         PL_compiling.cop_warnings = pWARN_ALL ;
3295     else if (PL_dowarn & G_WARN_ALL_OFF)
3296         PL_compiling.cop_warnings = pWARN_NONE ;
3297     else if (PL_taint_warn)
3298         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3299     else
3300         PL_compiling.cop_warnings = pWARN_STD ;
3301     SAVESPTR(PL_compiling.cop_io);
3302     PL_compiling.cop_io = Nullsv;
3303
3304     if (filter_sub || filter_child_proc) {
3305         SV *datasv = filter_add(run_user_filter, Nullsv);
3306         IoLINES(datasv) = filter_has_file;
3307         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3308         IoTOP_GV(datasv) = (GV *)filter_state;
3309         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3310     }
3311
3312     /* switch to eval mode */
3313     push_return(PL_op->op_next);
3314     PUSHBLOCK(cx, CXt_EVAL, SP);
3315     PUSHEVAL(cx, name, Nullgv);
3316
3317     SAVECOPLINE(&PL_compiling);
3318     CopLINE_set(&PL_compiling, 0);
3319
3320     PUTBACK;
3321
3322     /* Store and reset encoding. */
3323     encoding = PL_encoding;
3324     PL_encoding = Nullsv;
3325
3326     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3327
3328     /* Restore encoding. */
3329     PL_encoding = encoding;
3330
3331     return op;
3332 }
3333
3334 PP(pp_dofile)
3335 {
3336     return pp_require();
3337 }
3338
3339 PP(pp_entereval)
3340 {
3341     dSP;
3342     register PERL_CONTEXT *cx;
3343     dPOPss;
3344     I32 gimme = GIMME_V, was = PL_sub_generation;
3345     char tbuf[TYPE_DIGITS(long) + 12];
3346     char *tmpbuf = tbuf;
3347     char *safestr;
3348     STRLEN len;
3349     OP *ret;
3350     CV* runcv;
3351     U32 seq;
3352
3353     if (!SvPV(sv,len))
3354         RETPUSHUNDEF;
3355     TAINT_PROPER("eval");
3356
3357     ENTER;
3358     lex_start(sv);
3359     SAVETMPS;
3360
3361     /* switch to eval mode */
3362
3363     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3364         SV *sv = sv_newmortal();
3365         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3366                        (unsigned long)++PL_evalseq,
3367                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3368         tmpbuf = SvPVX(sv);
3369     }
3370     else
3371         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3372     SAVECOPFILE_FREE(&PL_compiling);
3373     CopFILE_set(&PL_compiling, tmpbuf+2);
3374     SAVECOPLINE(&PL_compiling);
3375     CopLINE_set(&PL_compiling, 1);
3376     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3377        deleting the eval's FILEGV from the stash before gv_check() runs
3378        (i.e. before run-time proper). To work around the coredump that
3379        ensues, we always turn GvMULTI_on for any globals that were
3380        introduced within evals. See force_ident(). GSAR 96-10-12 */
3381     safestr = savepv(tmpbuf);
3382     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3383     SAVEHINTS();
3384     PL_hints = PL_op->op_targ;
3385     SAVESPTR(PL_compiling.cop_warnings);
3386     if (specialWARN(PL_curcop->cop_warnings))
3387         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3388     else {
3389         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3390         SAVEFREESV(PL_compiling.cop_warnings);
3391     }
3392     SAVESPTR(PL_compiling.cop_io);
3393     if (specialCopIO(PL_curcop->cop_io))
3394         PL_compiling.cop_io = PL_curcop->cop_io;
3395     else {
3396         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3397         SAVEFREESV(PL_compiling.cop_io);
3398     }
3399     /* special case: an eval '' executed within the DB package gets lexically
3400      * placed in the first non-DB CV rather than the current CV - this
3401      * allows the debugger to execute code, find lexicals etc, in the
3402      * scope of the code being debugged. Passing &seq gets find_runcv
3403      * to do the dirty work for us */
3404     runcv = find_runcv(&seq);
3405
3406     push_return(PL_op->op_next);
3407     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3408     PUSHEVAL(cx, 0, Nullgv);
3409
3410     /* prepare to compile string */
3411
3412     if (PERLDB_LINE && PL_curstash != PL_debstash)
3413         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3414     PUTBACK;
3415     ret = doeval(gimme, NULL, runcv, seq);
3416     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3417         && ret != PL_op->op_next) {     /* Successive compilation. */
3418         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3419     }
3420     return DOCATCH(ret);
3421 }
3422
3423 PP(pp_leaveeval)
3424 {
3425     dSP;
3426     register SV **mark;
3427     SV **newsp;
3428     PMOP *newpm;
3429     I32 gimme;
3430     register PERL_CONTEXT *cx;
3431     OP *retop;
3432     U8 save_flags = PL_op -> op_flags;
3433     I32 optype;
3434
3435     POPBLOCK(cx,newpm);
3436     POPEVAL(cx);
3437     retop = pop_return();
3438
3439     TAINT_NOT;
3440     if (gimme == G_VOID)
3441         MARK = newsp;
3442     else if (gimme == G_SCALAR) {
3443         MARK = newsp + 1;
3444         if (MARK <= SP) {
3445             if (SvFLAGS(TOPs) & SVs_TEMP)
3446                 *MARK = TOPs;
3447             else
3448                 *MARK = sv_mortalcopy(TOPs);
3449         }
3450         else {
3451             MEXTEND(mark,0);
3452             *MARK = &PL_sv_undef;
3453         }
3454         SP = MARK;
3455     }
3456     else {
3457         /* in case LEAVE wipes old return values */
3458         for (mark = newsp + 1; mark <= SP; mark++) {
3459             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3460                 *mark = sv_mortalcopy(*mark);
3461                 TAINT_NOT;      /* Each item is independent */
3462             }
3463         }
3464     }
3465     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3466
3467 #ifdef DEBUGGING
3468     assert(CvDEPTH(PL_compcv) == 1);
3469 #endif
3470     CvDEPTH(PL_compcv) = 0;
3471     lex_end();
3472
3473     if (optype == OP_REQUIRE &&
3474         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3475     {
3476         /* Unassume the success we assumed earlier. */
3477         SV *nsv = cx->blk_eval.old_namesv;
3478         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3479         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3480         /* die_where() did LEAVE, or we won't be here */
3481     }
3482     else {
3483         LEAVE;
3484         if (!(save_flags & OPf_SPECIAL))
3485             sv_setpv(ERRSV,"");
3486     }
3487
3488     RETURNOP(retop);
3489 }
3490
3491 PP(pp_entertry)
3492 {
3493     dSP;
3494     register PERL_CONTEXT *cx;
3495     I32 gimme = GIMME_V;
3496
3497     ENTER;
3498     SAVETMPS;
3499
3500     push_return(cLOGOP->op_other->op_next);
3501     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3502     PUSHEVAL(cx, 0, 0);
3503
3504     PL_in_eval = EVAL_INEVAL;
3505     sv_setpv(ERRSV,"");
3506     PUTBACK;
3507     return DOCATCH(PL_op->op_next);
3508 }
3509
3510 PP(pp_leavetry)
3511 {
3512     dSP;
3513     register SV **mark;
3514     SV **newsp;
3515     PMOP *newpm;
3516     OP* retop;
3517     I32 gimme;
3518     register PERL_CONTEXT *cx;
3519     I32 optype;
3520
3521     POPBLOCK(cx,newpm);
3522     POPEVAL(cx);
3523     retop = pop_return();
3524
3525     TAINT_NOT;
3526     if (gimme == G_VOID)
3527         SP = newsp;
3528     else if (gimme == G_SCALAR) {
3529         MARK = newsp + 1;
3530         if (MARK <= SP) {
3531             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3532                 *MARK = TOPs;
3533             else
3534                 *MARK = sv_mortalcopy(TOPs);
3535         }
3536         else {
3537             MEXTEND(mark,0);
3538             *MARK = &PL_sv_undef;
3539         }
3540         SP = MARK;
3541     }
3542     else {
3543         /* in case LEAVE wipes old return values */
3544         for (mark = newsp + 1; mark <= SP; mark++) {
3545             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3546                 *mark = sv_mortalcopy(*mark);
3547                 TAINT_NOT;      /* Each item is independent */
3548             }
3549         }
3550     }
3551     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3552
3553     LEAVE;
3554     sv_setpv(ERRSV,"");
3555     RETURNOP(retop);
3556 }
3557
3558 STATIC void
3559 S_doparseform(pTHX_ SV *sv)
3560 {
3561     STRLEN len;
3562     register char *s = SvPV_force(sv, len);
3563     register char *send = s + len;
3564     register char *base = Nullch;
3565     register I32 skipspaces = 0;
3566     bool noblank   = FALSE;
3567     bool repeat    = FALSE;
3568     bool postspace = FALSE;
3569     U16 *fops;
3570     register U16 *fpc;
3571     U16 *linepc = 0;
3572     register I32 arg;
3573     bool ischop;
3574     int maxops = 2; /* FF_LINEMARK + FF_END) */
3575
3576     if (len == 0)
3577         Perl_croak(aTHX_ "Null picture in formline");
3578
3579     /* estimate the buffer size needed */
3580     for (base = s; s <= send; s++) {
3581         if (*s == '\n' || *s == '@' || *s == '^')
3582             maxops += 10;
3583     }
3584     s = base;
3585     base = Nullch;
3586
3587     New(804, fops, maxops, U16);
3588     fpc = fops;
3589
3590     if (s < send) {
3591         linepc = fpc;
3592         *fpc++ = FF_LINEMARK;
3593         noblank = repeat = FALSE;
3594         base = s;
3595     }
3596
3597     while (s <= send) {
3598         switch (*s++) {
3599         default:
3600             skipspaces = 0;
3601             continue;
3602
3603         case '~':
3604             if (*s == '~') {
3605                 repeat = TRUE;
3606                 *s = ' ';
3607             }
3608             noblank = TRUE;
3609             s[-1] = ' ';
3610             /* FALL THROUGH */
3611         case ' ': case '\t':
3612             skipspaces++;
3613             continue;
3614
3615         case '\n': case 0:
3616             arg = s - base;
3617             skipspaces++;
3618             arg -= skipspaces;
3619             if (arg) {
3620                 if (postspace)
3621                     *fpc++ = FF_SPACE;
3622                 *fpc++ = FF_LITERAL;
3623                 *fpc++ = (U16)arg;
3624             }
3625             postspace = FALSE;
3626             if (s <= send)
3627                 skipspaces--;
3628             if (skipspaces) {
3629                 *fpc++ = FF_SKIP;
3630                 *fpc++ = (U16)skipspaces;
3631             }
3632             skipspaces = 0;
3633             if (s <= send)
3634                 *fpc++ = FF_NEWLINE;
3635             if (noblank) {
3636                 *fpc++ = FF_BLANK;
3637                 if (repeat)
3638                     arg = fpc - linepc + 1;
3639                 else
3640                     arg = 0;
3641                 *fpc++ = (U16)arg;
3642             }
3643             if (s < send) {
3644                 linepc = fpc;
3645                 *fpc++ = FF_LINEMARK;
3646                 noblank = repeat = FALSE;
3647                 base = s;
3648             }
3649             else
3650                 s++;
3651             continue;
3652
3653         case '@':
3654         case '^':
3655             ischop = s[-1] == '^';
3656
3657             if (postspace) {
3658                 *fpc++ = FF_SPACE;
3659                 postspace = FALSE;
3660             }
3661             arg = (s - base) - 1;
3662             if (arg) {
3663                 *fpc++ = FF_LITERAL;
3664                 *fpc++ = (U16)arg;
3665             }
3666
3667             base = s - 1;
3668             *fpc++ = FF_FETCH;
3669             if (*s == '*') {
3670                 s++;
3671                 *fpc++ = 0;
3672                 *fpc++ = FF_LINEGLOB;
3673             }
3674             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3675                 arg = ischop ? 512 : 0;
3676                 base = s - 1;
3677                 while (*s == '#')
3678                     s++;
3679                 if (*s == '.') {
3680                     char *f;
3681                     s++;
3682                     f = s;
3683                     while (*s == '#')
3684                         s++;
3685                     arg |= 256 + (s - f);
3686                 }
3687                 *fpc++ = s - base;              /* fieldsize for FETCH */
3688                 *fpc++ = FF_DECIMAL;
3689                 *fpc++ = (U16)arg;
3690             }
3691             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3692                 arg = ischop ? 512 : 0;
3693                 base = s - 1;
3694                 s++;                                /* skip the '0' first */
3695                 while (*s == '#')
3696                     s++;
3697                 if (*s == '.') {
3698                     char *f;
3699                     s++;
3700                     f = s;
3701                     while (*s == '#')
3702                         s++;
3703                     arg |= 256 + (s - f);
3704                 }
3705                 *fpc++ = s - base;                /* fieldsize for FETCH */
3706                 *fpc++ = FF_0DECIMAL;
3707                 *fpc++ = (U16)arg;
3708             }
3709             else {
3710                 I32 prespace = 0;
3711                 bool ismore = FALSE;
3712
3713                 if (*s == '>') {
3714                     while (*++s == '>') ;
3715                     prespace = FF_SPACE;
3716                 }
3717                 else if (*s == '|') {
3718                     while (*++s == '|') ;
3719                     prespace = FF_HALFSPACE;
3720                     postspace = TRUE;
3721                 }
3722                 else {
3723                     if (*s == '<')
3724                         while (*++s == '<') ;
3725                     postspace = TRUE;
3726                 }
3727                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3728                     s += 3;
3729                     ismore = TRUE;
3730                 }
3731                 *fpc++ = s - base;              /* fieldsize for FETCH */
3732
3733                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3734
3735                 if (prespace)
3736                     *fpc++ = (U16)prespace;
3737                 *fpc++ = FF_ITEM;
3738                 if (ismore)
3739                     *fpc++ = FF_MORE;
3740                 if (ischop)
3741                     *fpc++ = FF_CHOP;
3742             }
3743             base = s;
3744             skipspaces = 0;
3745             continue;
3746         }
3747     }
3748     *fpc++ = FF_END;
3749
3750     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3751     arg = fpc - fops;
3752     { /* need to jump to the next word */
3753         int z;
3754         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3755         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3756         s = SvPVX(sv) + SvCUR(sv) + z;
3757     }
3758     Copy(fops, s, arg, U16);
3759     Safefree(fops);
3760     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3761     SvCOMPILED_on(sv);
3762 }
3763
3764 static I32
3765 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3766 {
3767     SV *datasv = FILTER_DATA(idx);
3768     int filter_has_file = IoLINES(datasv);
3769     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3770     SV *filter_state = (SV *)IoTOP_GV(datasv);
3771     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3772     int len = 0;
3773
3774     /* I was having segfault trouble under Linux 2.2.5 after a
3775        parse error occured.  (Had to hack around it with a test
3776        for PL_error_count == 0.)  Solaris doesn't segfault --
3777        not sure where the trouble is yet.  XXX */
3778
3779     if (filter_has_file) {
3780         len = FILTER_READ(idx+1, buf_sv, maxlen);
3781     }
3782
3783     if (filter_sub && len >= 0) {
3784         dSP;
3785         int count;
3786
3787         ENTER;
3788         SAVE_DEFSV;
3789         SAVETMPS;
3790         EXTEND(SP, 2);
3791
3792         DEFSV = buf_sv;
3793         PUSHMARK(SP);
3794         PUSHs(sv_2mortal(newSViv(maxlen)));
3795         if (filter_state) {
3796             PUSHs(filter_state);
3797         }
3798         PUTBACK;
3799         count = call_sv(filter_sub, G_SCALAR);
3800         SPAGAIN;
3801
3802         if (count > 0) {
3803             SV *out = POPs;
3804             if (SvOK(out)) {
3805                 len = SvIV(out);
3806             }
3807         }
3808
3809         PUTBACK;
3810         FREETMPS;
3811         LEAVE;
3812     }
3813
3814     if (len <= 0) {
3815         IoLINES(datasv) = 0;
3816         if (filter_child_proc) {
3817             SvREFCNT_dec(filter_child_proc);
3818             IoFMT_GV(datasv) = Nullgv;
3819         }
3820         if (filter_state) {
3821             SvREFCNT_dec(filter_state);
3822             IoTOP_GV(datasv) = Nullgv;
3823         }
3824         if (filter_sub) {
3825             SvREFCNT_dec(filter_sub);
3826             IoBOTTOM_GV(datasv) = Nullgv;
3827         }
3828         filter_del(run_user_filter);
3829     }
3830
3831     return len;
3832 }
3833
3834 /* perhaps someone can come up with a better name for
3835    this?  it is not really "absolute", per se ... */
3836 static bool
3837 S_path_is_absolute(pTHX_ char *name)
3838 {
3839     if (PERL_FILE_IS_ABSOLUTE(name)
3840 #ifdef MACOS_TRADITIONAL
3841         || (*name == ':'))
3842 #else
3843         || (*name == '.' && (name[1] == '/' ||
3844                              (name[1] == '.' && name[2] == '/'))))
3845 #endif
3846     {
3847         return TRUE;
3848     }
3849     else
3850         return FALSE;
3851 }