pp_ctl.c

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