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             }
2238             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2239                 AV* av;
2240                 av = GvAV(PL_defgv);
2241                 items = AvFILLp(av) + 1;
2242                 PL_stack_sp++;
2243                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2244                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2245                 PL_stack_sp += items;
2246             }
2247             if (CxTYPE(cx) == CXt_SUB &&
2248                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2249                 SvREFCNT_dec(cx->blk_sub.cv);
2250             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2251             LEAVE_SCOPE(oldsave);
2252
2253             /* Now do some callish stuff. */
2254             SAVETMPS;
2255             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2256             if (CvXSUB(cv)) {
2257 #ifdef PERL_XSUB_OLDSTYLE
2258                 if (CvOLDSTYLE(cv)) {
2259                     I32 (*fp3)(int,int,int);
2260                     while (SP > mark) {
2261                         SP[1] = SP[0];
2262                         SP--;
2263                     }
2264                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2265                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2266                                    mark - PL_stack_base + 1,
2267                                    items);
2268                     SP = PL_stack_base + items;
2269                 }
2270                 else
2271 #endif /* PERL_XSUB_OLDSTYLE */
2272                 {
2273                     SV **newsp;
2274                     I32 gimme;
2275
2276                     PL_stack_sp--;              /* There is no cv arg. */
2277                     /* Push a mark for the start of arglist */
2278                     PUSHMARK(mark);
2279                     (void)(*CvXSUB(cv))(aTHX_ cv);
2280                     /* Pop the current context like a decent sub should */
2281                     POPBLOCK(cx, PL_curpm);
2282                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2283                 }
2284                 LEAVE;
2285                 return pop_return();
2286             }
2287             else {
2288                 AV* padlist = CvPADLIST(cv);
2289                 if (CxTYPE(cx) == CXt_EVAL) {
2290                     PL_in_eval = cx->blk_eval.old_in_eval;
2291                     PL_eval_root = cx->blk_eval.old_eval_root;
2292                     cx->cx_type = CXt_SUB;
2293                     cx->blk_sub.hasargs = 0;
2294                 }
2295                 cx->blk_sub.cv = cv;
2296                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2297
2298                 CvDEPTH(cv)++;
2299                 if (CvDEPTH(cv) < 2)
2300                     (void)SvREFCNT_inc(cv);
2301                 else {
2302                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2303                         sub_crush_depth(cv);
2304                     pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2305                 }
2306                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2307                 if (cx->blk_sub.hasargs)
2308                 {
2309                     AV* av = (AV*)PAD_SVl(0);
2310                     SV** ary;
2311
2312                     cx->blk_sub.savearray = GvAV(PL_defgv);
2313                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2314                     CX_CURPAD_SAVE(cx->blk_sub);
2315                     cx->blk_sub.argarray = av;
2316                     ++mark;
2317
2318                     if (items >= AvMAX(av) + 1) {
2319                         ary = AvALLOC(av);
2320                         if (AvARRAY(av) != ary) {
2321                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2322                             SvPVX(av) = (char*)ary;
2323                         }
2324                         if (items >= AvMAX(av) + 1) {
2325                             AvMAX(av) = items - 1;
2326                             Renew(ary,items+1,SV*);
2327                             AvALLOC(av) = ary;
2328                             SvPVX(av) = (char*)ary;
2329                         }
2330                     }
2331                     Copy(mark,AvARRAY(av),items,SV*);
2332                     AvFILLp(av) = items - 1;
2333                     assert(!AvREAL(av));
2334                     while (items--) {
2335                         if (*mark)
2336                             SvTEMP_off(*mark);
2337                         mark++;
2338                     }
2339                 }
2340                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2341                     /*
2342                      * We do not care about using sv to call CV;
2343                      * it's for informational purposes only.
2344                      */
2345                     SV *sv = GvSV(PL_DBsub);
2346                     CV *gotocv;
2347
2348                     if (PERLDB_SUB_NN) {
2349                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2350                     } else {
2351                         save_item(sv);
2352                         gv_efullname3(sv, CvGV(cv), Nullch);
2353                     }
2354                     if (  PERLDB_GOTO
2355                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2356                         PUSHMARK( PL_stack_sp );
2357                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2358                         PL_stack_sp--;
2359                     }
2360                 }
2361                 RETURNOP(CvSTART(cv));
2362             }
2363         }
2364         else {
2365             label = SvPV(sv,n_a);
2366             if (!(do_dump || *label))
2367                 DIE(aTHX_ must_have_label);
2368         }
2369     }
2370     else if (PL_op->op_flags & OPf_SPECIAL) {
2371         if (! do_dump)
2372             DIE(aTHX_ must_have_label);
2373     }
2374     else
2375         label = cPVOP->op_pv;
2376
2377     if (label && *label) {
2378         OP *gotoprobe = 0;
2379         bool leaving_eval = FALSE;
2380         bool in_block = FALSE;
2381         PERL_CONTEXT *last_eval_cx = 0;
2382
2383         /* find label */
2384
2385         PL_lastgotoprobe = 0;
2386         *enterops = 0;
2387         for (ix = cxstack_ix; ix >= 0; ix--) {
2388             cx = &cxstack[ix];
2389             switch (CxTYPE(cx)) {
2390             case CXt_EVAL:
2391                 leaving_eval = TRUE;
2392                 if (CxREALEVAL(cx)) {
2393                     gotoprobe = (last_eval_cx ?
2394                                 last_eval_cx->blk_eval.old_eval_root :
2395                                 PL_eval_root);
2396                     last_eval_cx = cx;
2397                     break;
2398                 }
2399                 /* else fall through */
2400             case CXt_LOOP:
2401                 gotoprobe = cx->blk_oldcop->op_sibling;
2402                 break;
2403             case CXt_SUBST:
2404                 continue;
2405             case CXt_BLOCK:
2406                 if (ix) {
2407                     gotoprobe = cx->blk_oldcop->op_sibling;
2408                     in_block = TRUE;
2409                 } else
2410                     gotoprobe = PL_main_root;
2411                 break;
2412             case CXt_SUB:
2413                 if (CvDEPTH(cx->blk_sub.cv)) {
2414                     gotoprobe = CvROOT(cx->blk_sub.cv);
2415                     break;
2416                 }
2417                 /* FALL THROUGH */
2418             case CXt_FORMAT:
2419             case CXt_NULL:
2420                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2421             default:
2422                 if (ix)
2423                     DIE(aTHX_ "panic: goto");
2424                 gotoprobe = PL_main_root;
2425                 break;
2426             }
2427             if (gotoprobe) {
2428                 retop = dofindlabel(gotoprobe, label,
2429                                     enterops, enterops + GOTO_DEPTH);
2430                 if (retop)
2431                     break;
2432             }
2433             PL_lastgotoprobe = gotoprobe;
2434         }
2435         if (!retop)
2436             DIE(aTHX_ "Can't find label %s", label);
2437
2438         /* if we're leaving an eval, check before we pop any frames
2439            that we're not going to punt, otherwise the error
2440            won't be caught */
2441
2442         if (leaving_eval && *enterops && enterops[1]) {
2443             I32 i;
2444             for (i = 1; enterops[i]; i++)
2445                 if (enterops[i]->op_type == OP_ENTERITER)
2446                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2447         }
2448
2449         /* pop unwanted frames */
2450
2451         if (ix < cxstack_ix) {
2452             I32 oldsave;
2453
2454             if (ix < 0)
2455                 ix = 0;
2456             dounwind(ix);
2457             TOPBLOCK(cx);
2458             oldsave = PL_scopestack[PL_scopestack_ix];
2459             LEAVE_SCOPE(oldsave);
2460         }
2461
2462         /* push wanted frames */
2463
2464         if (*enterops && enterops[1]) {
2465             OP *oldop = PL_op;
2466             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2467             for (; enterops[ix]; ix++) {
2468                 PL_op = enterops[ix];
2469                 /* Eventually we may want to stack the needed arguments
2470                  * for each op.  For now, we punt on the hard ones. */
2471                 if (PL_op->op_type == OP_ENTERITER)
2472                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2473                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2474             }
2475             PL_op = oldop;
2476         }
2477     }
2478
2479     if (do_dump) {
2480 #ifdef VMS
2481         if (!retop) retop = PL_main_start;
2482 #endif
2483         PL_restartop = retop;
2484         PL_do_undump = TRUE;
2485
2486         my_unexec();
2487
2488         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2489         PL_do_undump = FALSE;
2490     }
2491
2492     RETURNOP(retop);
2493 }
2494
2495 PP(pp_exit)
2496 {
2497     dSP;
2498     I32 anum;
2499
2500     if (MAXARG < 1)
2501         anum = 0;
2502     else {
2503         anum = SvIVx(POPs);
2504 #ifdef VMS
2505         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2506             anum = 0;
2507         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2508 #endif
2509     }
2510     PL_exit_flags |= PERL_EXIT_EXPECTED;
2511     my_exit(anum);
2512     PUSHs(&PL_sv_undef);
2513     RETURN;
2514 }
2515
2516 #ifdef NOTYET
2517 PP(pp_nswitch)
2518 {
2519     dSP;
2520     NV value = SvNVx(GvSV(cCOP->cop_gv));
2521     register I32 match = I_32(value);
2522
2523     if (value < 0.0) {
2524         if (((NV)match) > value)
2525             --match;            /* was fractional--truncate other way */
2526     }
2527     match -= cCOP->uop.scop.scop_offset;
2528     if (match < 0)
2529         match = 0;
2530     else if (match > cCOP->uop.scop.scop_max)
2531         match = cCOP->uop.scop.scop_max;
2532     PL_op = cCOP->uop.scop.scop_next[match];
2533     RETURNOP(PL_op);
2534 }
2535
2536 PP(pp_cswitch)
2537 {
2538     dSP;
2539     register I32 match;
2540
2541     if (PL_multiline)
2542         PL_op = PL_op->op_next;                 /* can't assume anything */
2543     else {
2544         STRLEN n_a;
2545         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2546         match -= cCOP->uop.scop.scop_offset;
2547         if (match < 0)
2548             match = 0;
2549         else if (match > cCOP->uop.scop.scop_max)
2550             match = cCOP->uop.scop.scop_max;
2551         PL_op = cCOP->uop.scop.scop_next[match];
2552     }
2553     RETURNOP(PL_op);
2554 }
2555 #endif
2556
2557 /* Eval. */
2558
2559 STATIC void
2560 S_save_lines(pTHX_ AV *array, SV *sv)
2561 {
2562     register char *s = SvPVX(sv);
2563     register char *send = SvPVX(sv) + SvCUR(sv);
2564     register char *t;
2565     register I32 line = 1;
2566
2567     while (s && s < send) {
2568         SV *tmpstr = NEWSV(85,0);
2569
2570         sv_upgrade(tmpstr, SVt_PVMG);
2571         t = strchr(s, '\n');
2572         if (t)
2573             t++;
2574         else
2575             t = send;
2576
2577         sv_setpvn(tmpstr, s, t - s);
2578         av_store(array, line++, tmpstr);
2579         s = t;
2580     }
2581 }
2582
2583 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2584 STATIC void *
2585 S_docatch_body(pTHX_ va_list args)
2586 {
2587     return docatch_body();
2588 }
2589 #endif
2590
2591 STATIC void *
2592 S_docatch_body(pTHX)
2593 {
2594     CALLRUNOPS(aTHX);
2595     return NULL;
2596 }
2597
2598 STATIC OP *
2599 S_docatch(pTHX_ OP *o)
2600 {
2601     int ret;
2602     OP *oldop = PL_op;
2603     OP *retop;
2604     volatile PERL_SI *cursi = PL_curstackinfo;
2605     dJMPENV;
2606
2607 #ifdef DEBUGGING
2608     assert(CATCH_GET == TRUE);
2609 #endif
2610     PL_op = o;
2611
2612     /* Normally, the leavetry at the end of this block of ops will
2613      * pop an op off the return stack and continue there. By setting
2614      * the op to Nullop, we force an exit from the inner runops()
2615      * loop. DAPM.
2616      */
2617     retop = pop_return();
2618     push_return(Nullop);
2619
2620 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2621  redo_body:
2622     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2623 #else
2624     JMPENV_PUSH(ret);
2625 #endif
2626     switch (ret) {
2627     case 0:
2628 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2629  redo_body:
2630         docatch_body();
2631 #endif
2632         break;
2633     case 3:
2634         /* die caught by an inner eval - continue inner loop */
2635         if (PL_restartop && cursi == PL_curstackinfo) {
2636             PL_op = PL_restartop;
2637             PL_restartop = 0;
2638             goto redo_body;
2639         }
2640         /* a die in this eval - continue in outer loop */
2641         if (!PL_restartop)
2642             break;
2643         /* FALL THROUGH */
2644     default:
2645         JMPENV_POP;
2646         PL_op = oldop;
2647         JMPENV_JUMP(ret);
2648         /* NOTREACHED */
2649     }
2650     JMPENV_POP;
2651     PL_op = oldop;
2652     return retop;
2653 }
2654
2655 OP *
2656 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2657 /* sv Text to convert to OP tree. */
2658 /* startop op_free() this to undo. */
2659 /* code Short string id of the caller. */
2660 {
2661     dSP;                                /* Make POPBLOCK work. */
2662     PERL_CONTEXT *cx;
2663     SV **newsp;
2664     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2665     I32 optype;
2666     OP dummy;
2667     OP *rop;
2668     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2669     char *tmpbuf = tbuf;
2670     char *safestr;
2671     int runtime;
2672     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2673
2674     ENTER;
2675     lex_start(sv);
2676     SAVETMPS;
2677     /* switch to eval mode */
2678
2679     if (PL_curcop == &PL_compiling) {
2680         SAVECOPSTASH_FREE(&PL_compiling);
2681         CopSTASH_set(&PL_compiling, PL_curstash);
2682     }
2683     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2684         SV *sv = sv_newmortal();
2685         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2686                        code, (unsigned long)++PL_evalseq,
2687                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2688         tmpbuf = SvPVX(sv);
2689     }
2690     else
2691         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2692     SAVECOPFILE_FREE(&PL_compiling);
2693     CopFILE_set(&PL_compiling, tmpbuf+2);
2694     SAVECOPLINE(&PL_compiling);
2695     CopLINE_set(&PL_compiling, 1);
2696     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2697        deleting the eval's FILEGV from the stash before gv_check() runs
2698        (i.e. before run-time proper). To work around the coredump that
2699        ensues, we always turn GvMULTI_on for any globals that were
2700        introduced within evals. See force_ident(). GSAR 96-10-12 */
2701     safestr = savepv(tmpbuf);
2702     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2703     SAVEHINTS();
2704 #ifdef OP_IN_REGISTER
2705     PL_opsave = op;
2706 #else
2707     SAVEVPTR(PL_op);
2708 #endif
2709     PL_hints &= HINT_UTF8;
2710
2711     /* we get here either during compilation, or via pp_regcomp at runtime */
2712     runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2713     if (runtime)
2714         runcv = find_runcv(NULL);
2715
2716     PL_op = &dummy;
2717     PL_op->op_type = OP_ENTEREVAL;
2718     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2719     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2720     PUSHEVAL(cx, 0, Nullgv);
2721
2722     if (runtime)
2723         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2724     else
2725         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2726     POPBLOCK(cx,PL_curpm);
2727     POPEVAL(cx);
2728
2729     (*startop)->op_type = OP_NULL;
2730     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2731     lex_end();
2732     /* XXX DAPM do this properly one year */
2733     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2734     LEAVE;
2735     if (PL_curcop == &PL_compiling)
2736         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2737 #ifdef OP_IN_REGISTER
2738     op = PL_opsave;
2739 #endif
2740     return rop;
2741 }
2742
2743
2744 /*
2745 =for apidoc find_runcv
2746
2747 Locate the CV corresponding to the currently executing sub or eval.
2748 If db_seqp is non_null, skip CVs that are in the DB package and populate
2749 *db_seqp with the cop sequence number at the point that the DB:: code was
2750 entered. (allows debuggers to eval in the scope of the breakpoint rather
2751 than in in the scope of the debuger itself).
2752
2753 =cut
2754 */
2755
2756 CV*
2757 Perl_find_runcv(pTHX_ U32 *db_seqp)
2758 {
2759     I32          ix;
2760     PERL_SI      *si;
2761     PERL_CONTEXT *cx;
2762
2763     if (db_seqp)
2764         *db_seqp = PL_curcop->cop_seq;
2765     for (si = PL_curstackinfo; si; si = si->si_prev) {
2766         for (ix = si->si_cxix; ix >= 0; ix--) {
2767             cx = &(si->si_cxstack[ix]);
2768             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2769                 CV *cv = cx->blk_sub.cv;
2770                 /* skip DB:: code */
2771                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2772                     *db_seqp = cx->blk_oldcop->cop_seq;
2773                     continue;
2774                 }
2775                 return cv;
2776             }
2777             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2778                 return PL_compcv;
2779         }
2780     }
2781     return PL_main_cv;
2782 }
2783
2784
2785 /* Compile a require/do, an eval '', or a /(?{...})/.
2786  * In the last case, startop is non-null, and contains the address of
2787  * a pointer that should be set to the just-compiled code.
2788  * outside is the lexically enclosing CV (if any) that invoked us.
2789  */
2790
2791 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2792 STATIC OP *
2793 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2794 {
2795     dSP;
2796     OP *saveop = PL_op;
2797
2798     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2799                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2800                   : EVAL_INEVAL);
2801
2802     PUSHMARK(SP);
2803
2804     SAVESPTR(PL_compcv);
2805     PL_compcv = (CV*)NEWSV(1104,0);
2806     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2807     CvEVAL_on(PL_compcv);
2808     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2809     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2810
2811     CvOUTSIDE_SEQ(PL_compcv) = seq;
2812     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2813
2814     /* set up a scratch pad */
2815
2816     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2817
2818
2819     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2820
2821     /* make sure we compile in the right package */
2822
2823     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2824         SAVESPTR(PL_curstash);
2825         PL_curstash = CopSTASH(PL_curcop);
2826     }
2827     SAVESPTR(PL_beginav);
2828     PL_beginav = newAV();
2829     SAVEFREESV(PL_beginav);
2830     SAVEI32(PL_error_count);
2831
2832     /* try to compile it */
2833
2834     PL_eval_root = Nullop;
2835     PL_error_count = 0;
2836     PL_curcop = &PL_compiling;
2837     PL_curcop->cop_arybase = 0;
2838     if (saveop && saveop->op_flags & OPf_SPECIAL)
2839         PL_in_eval |= EVAL_KEEPERR;
2840     else
2841         sv_setpv(ERRSV,"");
2842     if (yyparse() || PL_error_count || !PL_eval_root) {
2843         SV **newsp;
2844         I32 gimme;
2845         PERL_CONTEXT *cx;
2846         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2847         STRLEN n_a;
2848
2849         PL_op = saveop;
2850         if (PL_eval_root) {
2851             op_free(PL_eval_root);
2852             PL_eval_root = Nullop;
2853         }
2854         SP = PL_stack_base + POPMARK;           /* pop original mark */
2855         if (!startop) {
2856             POPBLOCK(cx,PL_curpm);
2857             POPEVAL(cx);
2858             pop_return();
2859         }
2860         lex_end();
2861         LEAVE;
2862         if (optype == OP_REQUIRE) {
2863             char* msg = SvPVx(ERRSV, n_a);
2864             DIE(aTHX_ "%sCompilation failed in require",
2865                 *msg ? msg : "Unknown error\n");
2866         }
2867         else if (startop) {
2868             char* msg = SvPVx(ERRSV, n_a);
2869
2870             POPBLOCK(cx,PL_curpm);
2871             POPEVAL(cx);
2872             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2873                        (*msg ? msg : "Unknown error\n"));
2874         }
2875         else {
2876             char* msg = SvPVx(ERRSV, n_a);
2877             if (!*msg) {
2878                 sv_setpv(ERRSV, "Compilation error");
2879             }
2880         }
2881         RETPUSHUNDEF;
2882     }
2883     CopLINE_set(&PL_compiling, 0);
2884     if (startop) {
2885         *startop = PL_eval_root;
2886     } else
2887         SAVEFREEOP(PL_eval_root);
2888     if (gimme & G_VOID && ! PL_in_eval & EVAL_INREQUIRE)
2889         /*
2890          * EVAL_INREQUIRE (the code is being required) is special-cased :
2891          * in this case we want scalar context to be forced, instead
2892          * of void context, so a proper return value is returned from
2893          * C<require> via this leaveeval op.
2894          */
2895         scalarvoid(PL_eval_root);
2896     else if (gimme & G_ARRAY)
2897         list(PL_eval_root);
2898     else
2899         scalar(PL_eval_root);
2900
2901     DEBUG_x(dump_eval());
2902
2903     /* Register with debugger: */
2904     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2905         CV *cv = get_cv("DB::postponed", FALSE);
2906         if (cv) {
2907             dSP;
2908             PUSHMARK(SP);
2909             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2910             PUTBACK;
2911             call_sv((SV*)cv, G_DISCARD);
2912         }
2913     }
2914
2915     /* compiled okay, so do it */
2916
2917     CvDEPTH(PL_compcv) = 1;
2918     SP = PL_stack_base + POPMARK;               /* pop original mark */
2919     PL_op = saveop;                     /* The caller may need it. */
2920     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2921
2922     RETURNOP(PL_eval_start);
2923 }
2924
2925 STATIC PerlIO *
2926 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2927 {
2928     STRLEN namelen = strlen(name);
2929     PerlIO *fp;
2930
2931     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2932         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2933         char *pmc = SvPV_nolen(pmcsv);
2934         Stat_t pmstat;
2935         Stat_t pmcstat;
2936         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2937             fp = PerlIO_open(name, mode);
2938         }
2939         else {
2940             if (PerlLIO_stat(name, &pmstat) < 0 ||
2941                 pmstat.st_mtime < pmcstat.st_mtime)
2942             {
2943                 fp = PerlIO_open(pmc, mode);
2944             }
2945             else {
2946                 fp = PerlIO_open(name, mode);
2947             }
2948         }
2949         SvREFCNT_dec(pmcsv);
2950     }
2951     else {
2952         fp = PerlIO_open(name, mode);
2953     }
2954     return fp;
2955 }
2956
2957 PP(pp_require)
2958 {
2959     dSP;
2960     register PERL_CONTEXT *cx;
2961     SV *sv;
2962     char *name;
2963     STRLEN len;
2964     char *tryname = Nullch;
2965     SV *namesv = Nullsv;
2966     SV** svp;
2967     I32 gimme = GIMME_V;
2968     PerlIO *tryrsfp = 0;
2969     STRLEN n_a;
2970     int filter_has_file = 0;
2971     GV *filter_child_proc = 0;
2972     SV *filter_state = 0;
2973     SV *filter_sub = 0;
2974     SV *hook_sv = 0;
2975     SV *encoding;
2976     OP *op;
2977
2978     sv = POPs;
2979     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2980         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2981             UV rev = 0, ver = 0, sver = 0;
2982             STRLEN len;
2983             U8 *s = (U8*)SvPVX(sv);
2984             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2985             if (s < end) {
2986                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2987                 s += len;
2988                 if (s < end) {
2989                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
2990                     s += len;
2991                     if (s < end)
2992                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
2993                 }
2994             }
2995             if (PERL_REVISION < rev
2996                 || (PERL_REVISION == rev
2997                     && (PERL_VERSION < ver
2998                         || (PERL_VERSION == ver
2999                             && PERL_SUBVERSION < sver))))
3000             {
3001                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3002                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3003                     PERL_VERSION, PERL_SUBVERSION);
3004             }
3005             if (ckWARN(WARN_PORTABLE))
3006                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3007                         "v-string in use/require non-portable");
3008             RETPUSHYES;
3009         }
3010         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3011             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3012                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3013                 + 0.00000099 < SvNV(sv))
3014             {
3015                 NV nrev = SvNV(sv);
3016                 UV rev = (UV)nrev;
3017                 NV nver = (nrev - rev) * 1000;
3018                 UV ver = (UV)(nver + 0.0009);
3019                 NV nsver = (nver - ver) * 1000;
3020                 UV sver = (UV)(nsver + 0.0009);
3021
3022                 /* help out with the "use 5.6" confusion */
3023                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3024                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3025                         " (did you mean v%"UVuf".%03"UVuf"?)--"
3026                         "this is only v%d.%d.%d, stopped",
3027                         rev, ver, sver, rev, ver/100,
3028                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3029                 }
3030                 else {
3031                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3032                         "this is only v%d.%d.%d, stopped",
3033                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3034                         PERL_SUBVERSION);
3035                 }
3036             }
3037             RETPUSHYES;
3038         }
3039     }
3040     name = SvPV(sv, len);
3041     if (!(name && len > 0 && *name))
3042         DIE(aTHX_ "Null filename used");
3043     TAINT_PROPER("require");
3044     if (PL_op->op_type == OP_REQUIRE &&
3045       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
3046       *svp != &PL_sv_undef)
3047         RETPUSHYES;
3048
3049     /* prepare to compile file */
3050
3051     if (path_is_absolute(name)) {
3052         tryname = name;
3053         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
3054     }
3055 #ifdef MACOS_TRADITIONAL
3056     if (!tryrsfp) {
3057         char newname[256];
3058
3059         MacPerl_CanonDir(name, newname, 1);
3060         if (path_is_absolute(newname)) {
3061             tryname = newname;
3062             tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
3063         }
3064     }
3065 #endif
3066     if (!tryrsfp) {
3067         AV *ar = GvAVn(PL_incgv);
3068         I32 i;
3069 #ifdef VMS
3070         char *unixname;
3071         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3072 #endif
3073         {
3074             namesv = NEWSV(806, 0);
3075             for (i = 0; i <= AvFILL(ar); i++) {
3076                 SV *dirsv = *av_fetch(ar, i, TRUE);
3077
3078                 if (SvROK(dirsv)) {
3079                     int count;
3080                     SV *loader = dirsv;
3081
3082                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3083                         && !sv_isobject(loader))
3084                     {
3085                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3086                     }
3087
3088                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3089                                    PTR2UV(SvRV(dirsv)), name);
3090                     tryname = SvPVX(namesv);
3091                     tryrsfp = 0;
3092
3093                     ENTER;
3094                     SAVETMPS;
3095                     EXTEND(SP, 2);
3096
3097                     PUSHMARK(SP);
3098                     PUSHs(dirsv);
3099                     PUSHs(sv);
3100                     PUTBACK;
3101                     if (sv_isobject(loader))
3102                         count = call_method("INC", G_ARRAY);
3103                     else
3104                         count = call_sv(loader, G_ARRAY);
3105                     SPAGAIN;
3106
3107                     if (count > 0) {
3108                         int i = 0;
3109                         SV *arg;
3110
3111                         SP -= count - 1;
3112                         arg = SP[i++];
3113
3114                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3115                             arg = SvRV(arg);
3116                         }
3117
3118                         if (SvTYPE(arg) == SVt_PVGV) {
3119                             IO *io = GvIO((GV *)arg);
3120
3121                             ++filter_has_file;
3122
3123                             if (io) {
3124                                 tryrsfp = IoIFP(io);
3125                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3126                                     /* reading from a child process doesn't
3127                                        nest -- when returning from reading
3128                                        the inner module, the outer one is
3129                                        unreadable (closed?)  I've tried to
3130                                        save the gv to manage the lifespan of
3131                                        the pipe, but this didn't help. XXX */
3132                                     filter_child_proc = (GV *)arg;
3133                                     (void)SvREFCNT_inc(filter_child_proc);
3134                                 }
3135                                 else {
3136                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3137                                         PerlIO_close(IoOFP(io));
3138                                     }
3139                                     IoIFP(io) = Nullfp;
3140                                     IoOFP(io) = Nullfp;
3141                                 }
3142                             }
3143
3144                             if (i < count) {
3145                                 arg = SP[i++];
3146                             }
3147                         }
3148
3149                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3150                             filter_sub = arg;
3151                             (void)SvREFCNT_inc(filter_sub);
3152
3153                             if (i < count) {
3154                                 filter_state = SP[i];
3155                                 (void)SvREFCNT_inc(filter_state);
3156                             }
3157
3158                             if (tryrsfp == 0) {
3159                                 tryrsfp = PerlIO_open("/dev/null",
3160                                                       PERL_SCRIPT_MODE);
3161                             }
3162                         }
3163                     }
3164
3165                     PUTBACK;
3166                     FREETMPS;
3167                     LEAVE;
3168
3169                     if (tryrsfp) {
3170                         hook_sv = dirsv;
3171                         break;
3172                     }
3173
3174                     filter_has_file = 0;
3175                     if (filter_child_proc) {
3176                         SvREFCNT_dec(filter_child_proc);
3177                         filter_child_proc = 0;
3178                     }
3179                     if (filter_state) {
3180                         SvREFCNT_dec(filter_state);
3181                         filter_state = 0;
3182                     }
3183                     if (filter_sub) {
3184                         SvREFCNT_dec(filter_sub);
3185                         filter_sub = 0;
3186                     }
3187                 }
3188                 else {
3189                   if (!path_is_absolute(name)
3190 #ifdef MACOS_TRADITIONAL
3191                         /* We consider paths of the form :a:b ambiguous and interpret them first
3192                            as global then as local
3193                         */
3194                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3195 #endif
3196                   ) {
3197                     char *dir = SvPVx(dirsv, n_a);
3198 #ifdef MACOS_TRADITIONAL
3199                     char buf1[256];
3200                     char buf2[256];
3201
3202                     MacPerl_CanonDir(name, buf2, 1);
3203                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3204 #else
3205 #ifdef VMS
3206                     char *unixdir;
3207                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3208                         continue;
3209                     sv_setpv(namesv, unixdir);
3210                     sv_catpv(namesv, unixname);
3211 #else
3212                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3213 #endif
3214 #endif
3215                     TAINT_PROPER("require");
3216                     tryname = SvPVX(namesv);
3217                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3218                     if (tryrsfp) {
3219                         if (tryname[0] == '.' && tryname[1] == '/')
3220                             tryname += 2;
3221                         break;
3222                     }
3223                   }
3224                 }
3225             }
3226         }
3227     }
3228     SAVECOPFILE_FREE(&PL_compiling);
3229     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3230     SvREFCNT_dec(namesv);
3231     if (!tryrsfp) {
3232         if (PL_op->op_type == OP_REQUIRE) {
3233             char *msgstr = name;
3234             if (namesv) {                       /* did we lookup @INC? */
3235                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3236                 SV *dirmsgsv = NEWSV(0, 0);
3237                 AV *ar = GvAVn(PL_incgv);
3238                 I32 i;
3239                 sv_catpvn(msg, " in @INC", 8);
3240                 if (instr(SvPVX(msg), ".h "))
3241                     sv_catpv(msg, " (change .h to .ph maybe?)");
3242                 if (instr(SvPVX(msg), ".ph "))
3243                     sv_catpv(msg, " (did you run h2ph?)");
3244                 sv_catpv(msg, " (@INC contains:");
3245                 for (i = 0; i <= AvFILL(ar); i++) {
3246                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3247                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3248                     sv_catsv(msg, dirmsgsv);
3249                 }
3250                 sv_catpvn(msg, ")", 1);
3251                 SvREFCNT_dec(dirmsgsv);
3252                 msgstr = SvPV_nolen(msg);
3253             }
3254             DIE(aTHX_ "Can't locate %s", msgstr);
3255         }
3256
3257         RETPUSHUNDEF;
3258     }
3259     else
3260         SETERRNO(0, SS_NORMAL);
3261
3262     /* Assume success here to prevent recursive requirement. */
3263     len = strlen(name);
3264     /* Check whether a hook in @INC has already filled %INC */
3265     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3266         (void)hv_store(GvHVn(PL_incgv), name, len,
3267                        (hook_sv ? SvREFCNT_inc(hook_sv)
3268                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3269                        0 );
3270     }
3271
3272     ENTER;
3273     SAVETMPS;
3274     lex_start(sv_2mortal(newSVpvn("",0)));
3275     SAVEGENERICSV(PL_rsfp_filters);
3276     PL_rsfp_filters = Nullav;
3277
3278     PL_rsfp = tryrsfp;
3279     SAVEHINTS();
3280     PL_hints = 0;
3281     SAVESPTR(PL_compiling.cop_warnings);
3282     if (PL_dowarn & G_WARN_ALL_ON)
3283         PL_compiling.cop_warnings = pWARN_ALL ;
3284     else if (PL_dowarn & G_WARN_ALL_OFF)
3285         PL_compiling.cop_warnings = pWARN_NONE ;
3286     else if (PL_taint_warn)
3287         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3288     else
3289         PL_compiling.cop_warnings = pWARN_STD ;
3290     SAVESPTR(PL_compiling.cop_io);
3291     PL_compiling.cop_io = Nullsv;
3292
3293     if (filter_sub || filter_child_proc) {
3294         SV *datasv = filter_add(run_user_filter, Nullsv);
3295         IoLINES(datasv) = filter_has_file;
3296         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3297         IoTOP_GV(datasv) = (GV *)filter_state;
3298         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3299     }
3300
3301     /* switch to eval mode */
3302     push_return(PL_op->op_next);
3303     PUSHBLOCK(cx, CXt_EVAL, SP);
3304     PUSHEVAL(cx, name, Nullgv);
3305
3306     SAVECOPLINE(&PL_compiling);
3307     CopLINE_set(&PL_compiling, 0);
3308
3309     PUTBACK;
3310
3311     /* Store and reset encoding. */
3312     encoding = PL_encoding;
3313     PL_encoding = Nullsv;
3314
3315     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3316
3317     /* Restore encoding. */
3318     PL_encoding = encoding;
3319
3320     return op;
3321 }
3322
3323 PP(pp_dofile)
3324 {
3325     return pp_require();
3326 }
3327
3328 PP(pp_entereval)
3329 {
3330     dSP;
3331     register PERL_CONTEXT *cx;
3332     dPOPss;
3333     I32 gimme = GIMME_V, was = PL_sub_generation;
3334     char tbuf[TYPE_DIGITS(long) + 12];
3335     char *tmpbuf = tbuf;
3336     char *safestr;
3337     STRLEN len;
3338     OP *ret;
3339     CV* runcv;
3340     U32 seq;
3341
3342     if (!SvPV(sv,len))
3343         RETPUSHUNDEF;
3344     TAINT_PROPER("eval");
3345
3346     ENTER;
3347     lex_start(sv);
3348     SAVETMPS;
3349
3350     /* switch to eval mode */
3351
3352     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3353         SV *sv = sv_newmortal();
3354         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3355                        (unsigned long)++PL_evalseq,
3356                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3357         tmpbuf = SvPVX(sv);
3358     }
3359     else
3360         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3361     SAVECOPFILE_FREE(&PL_compiling);
3362     CopFILE_set(&PL_compiling, tmpbuf+2);
3363     SAVECOPLINE(&PL_compiling);
3364     CopLINE_set(&PL_compiling, 1);
3365     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3366        deleting the eval's FILEGV from the stash before gv_check() runs
3367        (i.e. before run-time proper). To work around the coredump that
3368        ensues, we always turn GvMULTI_on for any globals that were
3369        introduced within evals. See force_ident(). GSAR 96-10-12 */
3370     safestr = savepv(tmpbuf);
3371     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3372     SAVEHINTS();
3373     PL_hints = PL_op->op_targ;
3374     SAVESPTR(PL_compiling.cop_warnings);
3375     if (specialWARN(PL_curcop->cop_warnings))
3376         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3377     else {
3378         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3379         SAVEFREESV(PL_compiling.cop_warnings);
3380     }
3381     SAVESPTR(PL_compiling.cop_io);
3382     if (specialCopIO(PL_curcop->cop_io))
3383         PL_compiling.cop_io = PL_curcop->cop_io;
3384     else {
3385         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3386         SAVEFREESV(PL_compiling.cop_io);
3387     }
3388     /* special case: an eval '' executed within the DB package gets lexically
3389      * placed in the first non-DB CV rather than the current CV - this
3390      * allows the debugger to execute code, find lexicals etc, in the
3391      * scope of the code being debugged. Passing &seq gets find_runcv
3392      * to do the dirty work for us */
3393     runcv = find_runcv(&seq);
3394
3395     push_return(PL_op->op_next);
3396     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3397     PUSHEVAL(cx, 0, Nullgv);
3398
3399     /* prepare to compile string */
3400
3401     if (PERLDB_LINE && PL_curstash != PL_debstash)
3402         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3403     PUTBACK;
3404     ret = doeval(gimme, NULL, runcv, seq);
3405     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3406         && ret != PL_op->op_next) {     /* Successive compilation. */
3407         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3408     }
3409     return DOCATCH(ret);
3410 }
3411
3412 PP(pp_leaveeval)
3413 {
3414     dSP;
3415     register SV **mark;
3416     SV **newsp;
3417     PMOP *newpm;
3418     I32 gimme;
3419     register PERL_CONTEXT *cx;
3420     OP *retop;
3421     U8 save_flags = PL_op -> op_flags;
3422     I32 optype;
3423
3424     POPBLOCK(cx,newpm);
3425     POPEVAL(cx);
3426     retop = pop_return();
3427
3428     TAINT_NOT;
3429     if (gimme == G_VOID)
3430         MARK = newsp;
3431     else if (gimme == G_SCALAR) {
3432         MARK = newsp + 1;
3433         if (MARK <= SP) {
3434             if (SvFLAGS(TOPs) & SVs_TEMP)
3435                 *MARK = TOPs;
3436             else
3437                 *MARK = sv_mortalcopy(TOPs);
3438         }
3439         else {
3440             MEXTEND(mark,0);
3441             *MARK = &PL_sv_undef;
3442         }
3443         SP = MARK;
3444     }
3445     else {
3446         /* in case LEAVE wipes old return values */
3447         for (mark = newsp + 1; mark <= SP; mark++) {
3448             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3449                 *mark = sv_mortalcopy(*mark);
3450                 TAINT_NOT;      /* Each item is independent */
3451             }
3452         }
3453     }
3454     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3455
3456 #ifdef DEBUGGING
3457     assert(CvDEPTH(PL_compcv) == 1);
3458 #endif
3459     CvDEPTH(PL_compcv) = 0;
3460     lex_end();
3461
3462     if (optype == OP_REQUIRE &&
3463         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3464     {
3465         /* Unassume the success we assumed earlier. */
3466         SV *nsv = cx->blk_eval.old_namesv;
3467         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3468         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3469         /* die_where() did LEAVE, or we won't be here */
3470     }
3471     else {
3472         LEAVE;
3473         if (!(save_flags & OPf_SPECIAL))
3474             sv_setpv(ERRSV,"");
3475     }
3476
3477     RETURNOP(retop);
3478 }
3479
3480 PP(pp_entertry)
3481 {
3482     dSP;
3483     register PERL_CONTEXT *cx;
3484     I32 gimme = GIMME_V;
3485
3486     ENTER;
3487     SAVETMPS;
3488
3489     push_return(cLOGOP->op_other->op_next);
3490     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3491     PUSHEVAL(cx, 0, 0);
3492
3493     PL_in_eval = EVAL_INEVAL;
3494     sv_setpv(ERRSV,"");
3495     PUTBACK;
3496     return DOCATCH(PL_op->op_next);
3497 }
3498
3499 PP(pp_leavetry)
3500 {
3501     dSP;
3502     register SV **mark;
3503     SV **newsp;
3504     PMOP *newpm;
3505     OP* retop;
3506     I32 gimme;
3507     register PERL_CONTEXT *cx;
3508     I32 optype;
3509
3510     POPBLOCK(cx,newpm);
3511     POPEVAL(cx);
3512     retop = pop_return();
3513
3514     TAINT_NOT;
3515     if (gimme == G_VOID)
3516         SP = newsp;
3517     else if (gimme == G_SCALAR) {
3518         MARK = newsp + 1;
3519         if (MARK <= SP) {
3520             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3521                 *MARK = TOPs;
3522             else
3523                 *MARK = sv_mortalcopy(TOPs);
3524         }
3525         else {
3526             MEXTEND(mark,0);
3527             *MARK = &PL_sv_undef;
3528         }
3529         SP = MARK;
3530     }
3531     else {
3532         /* in case LEAVE wipes old return values */
3533         for (mark = newsp + 1; mark <= SP; mark++) {
3534             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3535                 *mark = sv_mortalcopy(*mark);
3536                 TAINT_NOT;      /* Each item is independent */
3537             }
3538         }
3539     }
3540     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3541
3542     LEAVE;
3543     sv_setpv(ERRSV,"");
3544     RETURNOP(retop);
3545 }
3546
3547 STATIC void
3548 S_doparseform(pTHX_ SV *sv)
3549 {
3550     STRLEN len;
3551     register char *s = SvPV_force(sv, len);
3552     register char *send = s + len;
3553     register char *base = Nullch;
3554     register I32 skipspaces = 0;
3555     bool noblank   = FALSE;
3556     bool repeat    = FALSE;
3557     bool postspace = FALSE;
3558     U16 *fops;
3559     register U16 *fpc;
3560     U16 *linepc = 0;
3561     register I32 arg;
3562     bool ischop;
3563
3564     if (len == 0)
3565         Perl_croak(aTHX_ "Null picture in formline");
3566
3567     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3568     fpc = fops;
3569
3570     if (s < send) {
3571         linepc = fpc;
3572         *fpc++ = FF_LINEMARK;
3573         noblank = repeat = FALSE;
3574         base = s;
3575     }
3576
3577     while (s <= send) {
3578         switch (*s++) {
3579         default:
3580             skipspaces = 0;
3581             continue;
3582
3583         case '~':
3584             if (*s == '~') {
3585                 repeat = TRUE;
3586                 *s = ' ';
3587             }
3588             noblank = TRUE;
3589             s[-1] = ' ';
3590             /* FALL THROUGH */
3591         case ' ': case '\t':
3592             skipspaces++;
3593             continue;
3594
3595         case '\n': case 0:
3596             arg = s - base;
3597             skipspaces++;
3598             arg -= skipspaces;
3599             if (arg) {
3600                 if (postspace)
3601                     *fpc++ = FF_SPACE;
3602                 *fpc++ = FF_LITERAL;
3603                 *fpc++ = (U16)arg;
3604             }
3605             postspace = FALSE;
3606             if (s <= send)
3607                 skipspaces--;
3608             if (skipspaces) {
3609                 *fpc++ = FF_SKIP;
3610                 *fpc++ = (U16)skipspaces;
3611             }
3612             skipspaces = 0;
3613             if (s <= send)
3614                 *fpc++ = FF_NEWLINE;
3615             if (noblank) {
3616                 *fpc++ = FF_BLANK;
3617                 if (repeat)
3618                     arg = fpc - linepc + 1;
3619                 else
3620                     arg = 0;
3621                 *fpc++ = (U16)arg;
3622             }
3623             if (s < send) {
3624                 linepc = fpc;
3625                 *fpc++ = FF_LINEMARK;
3626                 noblank = repeat = FALSE;
3627                 base = s;
3628             }
3629             else
3630                 s++;
3631             continue;
3632
3633         case '@':
3634         case '^':
3635             ischop = s[-1] == '^';
3636
3637             if (postspace) {
3638                 *fpc++ = FF_SPACE;
3639                 postspace = FALSE;
3640             }
3641             arg = (s - base) - 1;
3642             if (arg) {
3643                 *fpc++ = FF_LITERAL;
3644                 *fpc++ = (U16)arg;
3645             }
3646
3647             base = s - 1;
3648             *fpc++ = FF_FETCH;
3649             if (*s == '*') {
3650                 s++;
3651                 *fpc++ = 0;
3652                 *fpc++ = FF_LINEGLOB;
3653             }
3654             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3655                 arg = ischop ? 512 : 0;
3656                 base = s - 1;
3657                 while (*s == '#')
3658                     s++;
3659                 if (*s == '.') {
3660                     char *f;
3661                     s++;
3662                     f = s;
3663                     while (*s == '#')
3664                         s++;
3665                     arg |= 256 + (s - f);
3666                 }
3667                 *fpc++ = s - base;              /* fieldsize for FETCH */
3668                 *fpc++ = FF_DECIMAL;
3669                 *fpc++ = (U16)arg;
3670             }
3671             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3672                 arg = ischop ? 512 : 0;
3673                 base = s - 1;
3674                 s++;                                /* skip the '0' first */
3675                 while (*s == '#')
3676                     s++;
3677                 if (*s == '.') {
3678                     char *f;
3679                     s++;
3680                     f = s;
3681                     while (*s == '#')
3682                         s++;
3683                     arg |= 256 + (s - f);
3684                 }
3685                 *fpc++ = s - base;                /* fieldsize for FETCH */
3686                 *fpc++ = FF_0DECIMAL;
3687                 *fpc++ = (U16)arg;
3688             }
3689             else {
3690                 I32 prespace = 0;
3691                 bool ismore = FALSE;
3692
3693                 if (*s == '>') {
3694                     while (*++s == '>') ;
3695                     prespace = FF_SPACE;
3696                 }
3697                 else if (*s == '|') {
3698                     while (*++s == '|') ;
3699                     prespace = FF_HALFSPACE;
3700                     postspace = TRUE;
3701                 }
3702                 else {
3703                     if (*s == '<')
3704                         while (*++s == '<') ;
3705                     postspace = TRUE;
3706                 }
3707                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3708                     s += 3;
3709                     ismore = TRUE;
3710                 }
3711                 *fpc++ = s - base;              /* fieldsize for FETCH */
3712
3713                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3714
3715                 if (prespace)
3716                     *fpc++ = (U16)prespace;
3717                 *fpc++ = FF_ITEM;
3718                 if (ismore)
3719                     *fpc++ = FF_MORE;
3720                 if (ischop)
3721                     *fpc++ = FF_CHOP;
3722             }
3723             base = s;
3724             skipspaces = 0;
3725             continue;
3726         }
3727     }
3728     *fpc++ = FF_END;
3729
3730     arg = fpc - fops;
3731     { /* need to jump to the next word */
3732         int z;
3733         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3734         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3735         s = SvPVX(sv) + SvCUR(sv) + z;
3736     }
3737     Copy(fops, s, arg, U16);
3738     Safefree(fops);
3739     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3740     SvCOMPILED_on(sv);
3741 }
3742
3743 static I32
3744 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3745 {
3746     SV *datasv = FILTER_DATA(idx);
3747     int filter_has_file = IoLINES(datasv);
3748     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3749     SV *filter_state = (SV *)IoTOP_GV(datasv);
3750     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3751     int len = 0;
3752
3753     /* I was having segfault trouble under Linux 2.2.5 after a
3754        parse error occured.  (Had to hack around it with a test
3755        for PL_error_count == 0.)  Solaris doesn't segfault --
3756        not sure where the trouble is yet.  XXX */
3757
3758     if (filter_has_file) {
3759         len = FILTER_READ(idx+1, buf_sv, maxlen);
3760     }
3761
3762     if (filter_sub && len >= 0) {
3763         dSP;
3764         int count;
3765
3766         ENTER;
3767         SAVE_DEFSV;
3768         SAVETMPS;
3769         EXTEND(SP, 2);
3770
3771         DEFSV = buf_sv;
3772         PUSHMARK(SP);
3773         PUSHs(sv_2mortal(newSViv(maxlen)));
3774         if (filter_state) {
3775             PUSHs(filter_state);
3776         }
3777         PUTBACK;
3778         count = call_sv(filter_sub, G_SCALAR);
3779         SPAGAIN;
3780
3781         if (count > 0) {
3782             SV *out = POPs;
3783             if (SvOK(out)) {
3784                 len = SvIV(out);
3785             }
3786         }
3787
3788         PUTBACK;
3789         FREETMPS;
3790         LEAVE;
3791     }
3792
3793     if (len <= 0) {
3794         IoLINES(datasv) = 0;
3795         if (filter_child_proc) {
3796             SvREFCNT_dec(filter_child_proc);
3797             IoFMT_GV(datasv) = Nullgv;
3798         }
3799         if (filter_state) {
3800             SvREFCNT_dec(filter_state);
3801             IoTOP_GV(datasv) = Nullgv;
3802         }
3803         if (filter_sub) {
3804             SvREFCNT_dec(filter_sub);
3805             IoBOTTOM_GV(datasv) = Nullgv;
3806         }
3807         filter_del(run_user_filter);
3808     }
3809
3810     return len;
3811 }
3812
3813 /* perhaps someone can come up with a better name for
3814    this?  it is not really "absolute", per se ... */
3815 static bool
3816 S_path_is_absolute(pTHX_ char *name)
3817 {
3818     if (PERL_FILE_IS_ABSOLUTE(name)
3819 #ifdef MACOS_TRADITIONAL
3820         || (*name == ':'))
3821 #else
3822         || (*name == '.' && (name[1] == '/' ||
3823                              (name[1] == '.' && name[2] == '/'))))
3824 #endif
3825     {
3826         return TRUE;
3827     }
3828     else
3829         return FALSE;
3830 }