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