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 PP(pp_flop)
1035 {
1036     dSP;
1037
1038     if (GIMME == G_ARRAY) {
1039         dPOPPOPssrl;
1040         register I32 i, j;
1041         register SV *sv;
1042         I32 max;
1043
1044         if (SvGMAGICAL(left))
1045             mg_get(left);
1046         if (SvGMAGICAL(right))
1047             mg_get(right);
1048
1049         /* This code tries to decide if "$left .. $right" should use the
1050            magical string increment, or if the range is numeric (we make
1051            an exception for .."0" [#18165]). AMS 20021031. */
1052
1053         if (SvNIOKp(left) || !SvPOKp(left) ||
1054             SvNIOKp(right) || !SvPOKp(right) ||
1055             (looks_like_number(left) && *SvPVX(left) != '0' &&
1056              looks_like_number(right)))
1057         {
1058             if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
1059                 DIE(aTHX_ "Range iterator outside integer range");
1060             i = SvIV(left);
1061             max = SvIV(right);
1062             if (max >= i) {
1063                 j = max - i + 1;
1064                 EXTEND_MORTAL(j);
1065                 EXTEND(SP, j);
1066             }
1067             else
1068                 j = 0;
1069             while (j--) {
1070                 sv = sv_2mortal(newSViv(i++));
1071                 PUSHs(sv);
1072             }
1073         }
1074         else {
1075             SV *final = sv_mortalcopy(right);
1076             STRLEN len, n_a;
1077             char *tmps = SvPV(final, len);
1078
1079             sv = sv_mortalcopy(left);
1080             SvPV_force(sv,n_a);
1081             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1082                 XPUSHs(sv);
1083                 if (strEQ(SvPVX(sv),tmps))
1084                     break;
1085                 sv = sv_2mortal(newSVsv(sv));
1086                 sv_inc(sv);
1087             }
1088         }
1089     }
1090     else {
1091         dTOPss;
1092         SV *targ = PAD_SV(cUNOP->op_first->op_targ);
1093         int flop = 0;
1094         sv_inc(targ);
1095
1096         if (PL_op->op_private & OPpFLIP_LINENUM) {
1097             if (GvIO(PL_last_in_gv)) {
1098                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1099             }
1100             else {
1101                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
1102                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1103             }
1104         }
1105         else {
1106             flop = SvTRUE(sv);
1107         }
1108
1109         if (flop) {
1110             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1111             sv_catpv(targ, "E0");
1112         }
1113         SETs(targ);
1114     }
1115
1116     RETURN;
1117 }
1118
1119 /* Control. */
1120
1121 static char *context_name[] = {
1122     "pseudo-block",
1123     "subroutine",
1124     "eval",
1125     "loop",
1126     "substitution",
1127     "block",
1128     "format"
1129 };
1130
1131 STATIC I32
1132 S_dopoptolabel(pTHX_ char *label)
1133 {
1134     register I32 i;
1135     register PERL_CONTEXT *cx;
1136
1137     for (i = cxstack_ix; i >= 0; i--) {
1138         cx = &cxstack[i];
1139         switch (CxTYPE(cx)) {
1140         case CXt_SUBST:
1141         case CXt_SUB:
1142         case CXt_FORMAT:
1143         case CXt_EVAL:
1144         case CXt_NULL:
1145             if (ckWARN(WARN_EXITING))
1146                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1147                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1148             if (CxTYPE(cx) == CXt_NULL)
1149                 return -1;
1150             break;
1151         case CXt_LOOP:
1152             if (!cx->blk_loop.label ||
1153               strNE(label, cx->blk_loop.label) ) {
1154                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1155                         (long)i, cx->blk_loop.label));
1156                 continue;
1157             }
1158             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1159             return i;
1160         }
1161     }
1162     return i;
1163 }
1164
1165 I32
1166 Perl_dowantarray(pTHX)
1167 {
1168     I32 gimme = block_gimme();
1169     return (gimme == G_VOID) ? G_SCALAR : gimme;
1170 }
1171
1172 I32
1173 Perl_block_gimme(pTHX)
1174 {
1175     I32 cxix;
1176
1177     cxix = dopoptosub(cxstack_ix);
1178     if (cxix < 0)
1179         return G_VOID;
1180
1181     switch (cxstack[cxix].blk_gimme) {
1182     case G_VOID:
1183         return G_VOID;
1184     case G_SCALAR:
1185         return G_SCALAR;
1186     case G_ARRAY:
1187         return G_ARRAY;
1188     default:
1189         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1190         /* NOTREACHED */
1191         return 0;
1192     }
1193 }
1194
1195 I32
1196 Perl_is_lvalue_sub(pTHX)
1197 {
1198     I32 cxix;
1199
1200     cxix = dopoptosub(cxstack_ix);
1201     assert(cxix >= 0);  /* We should only be called from inside subs */
1202
1203     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1204         return cxstack[cxix].blk_sub.lval;
1205     else
1206         return 0;
1207 }
1208
1209 STATIC I32
1210 S_dopoptosub(pTHX_ I32 startingblock)
1211 {
1212     return dopoptosub_at(cxstack, startingblock);
1213 }
1214
1215 STATIC I32
1216 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1217 {
1218     I32 i;
1219     register PERL_CONTEXT *cx;
1220     for (i = startingblock; i >= 0; i--) {
1221         cx = &cxstk[i];
1222         switch (CxTYPE(cx)) {
1223         default:
1224             continue;
1225         case CXt_EVAL:
1226         case CXt_SUB:
1227         case CXt_FORMAT:
1228             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1229             return i;
1230         }
1231     }
1232     return i;
1233 }
1234
1235 STATIC I32
1236 S_dopoptoeval(pTHX_ I32 startingblock)
1237 {
1238     I32 i;
1239     register PERL_CONTEXT *cx;
1240     for (i = startingblock; i >= 0; i--) {
1241         cx = &cxstack[i];
1242         switch (CxTYPE(cx)) {
1243         default:
1244             continue;
1245         case CXt_EVAL:
1246             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1247             return i;
1248         }
1249     }
1250     return i;
1251 }
1252
1253 STATIC I32
1254 S_dopoptoloop(pTHX_ I32 startingblock)
1255 {
1256     I32 i;
1257     register PERL_CONTEXT *cx;
1258     for (i = startingblock; i >= 0; i--) {
1259         cx = &cxstack[i];
1260         switch (CxTYPE(cx)) {
1261         case CXt_SUBST:
1262         case CXt_SUB:
1263         case CXt_FORMAT:
1264         case CXt_EVAL:
1265         case CXt_NULL:
1266             if (ckWARN(WARN_EXITING))
1267                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1268                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1269             if ((CxTYPE(cx)) == CXt_NULL)
1270                 return -1;
1271             break;
1272         case CXt_LOOP:
1273             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1274             return i;
1275         }
1276     }
1277     return i;
1278 }
1279
1280 void
1281 Perl_dounwind(pTHX_ I32 cxix)
1282 {
1283     register PERL_CONTEXT *cx;
1284     I32 optype;
1285
1286     while (cxstack_ix > cxix) {
1287         SV *sv;
1288         cx = &cxstack[cxstack_ix];
1289         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1290                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1291         /* Note: we don't need to restore the base context info till the end. */
1292         switch (CxTYPE(cx)) {
1293         case CXt_SUBST:
1294             POPSUBST(cx);
1295             continue;  /* not break */
1296         case CXt_SUB:
1297             POPSUB(cx,sv);
1298             LEAVESUB(sv);
1299             break;
1300         case CXt_EVAL:
1301             POPEVAL(cx);
1302             break;
1303         case CXt_LOOP:
1304             POPLOOP(cx);
1305             break;
1306         case CXt_NULL:
1307             break;
1308         case CXt_FORMAT:
1309             POPFORMAT(cx);
1310             break;
1311         }
1312         cxstack_ix--;
1313     }
1314 }
1315
1316 void
1317 Perl_qerror(pTHX_ SV *err)
1318 {
1319     if (PL_in_eval)
1320         sv_catsv(ERRSV, err);
1321     else if (PL_errors)
1322         sv_catsv(PL_errors, err);
1323     else
1324         Perl_warn(aTHX_ "%"SVf, err);
1325     ++PL_error_count;
1326 }
1327
1328 OP *
1329 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1330 {
1331     STRLEN n_a;
1332
1333     if (PL_in_eval) {
1334         I32 cxix;
1335         register PERL_CONTEXT *cx;
1336         I32 gimme;
1337         SV **newsp;
1338
1339         if (message) {
1340             if (PL_in_eval & EVAL_KEEPERR) {
1341                 static char prefix[] = "\t(in cleanup) ";
1342                 SV *err = ERRSV;
1343                 char *e = Nullch;
1344                 if (!SvPOK(err))
1345                     sv_setpv(err,"");
1346                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1347                     e = SvPV(err, n_a);
1348                     e += n_a - msglen;
1349                     if (*e != *message || strNE(e,message))
1350                         e = Nullch;
1351                 }
1352                 if (!e) {
1353                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1354                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1355                     sv_catpvn(err, message, msglen);
1356                     if (ckWARN(WARN_MISC)) {
1357                         STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1358                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1359                     }
1360                 }
1361             }
1362             else {
1363                 sv_setpvn(ERRSV, message, msglen);
1364             }
1365         }
1366
1367         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1368                && PL_curstackinfo->si_prev)
1369         {
1370             dounwind(-1);
1371             POPSTACK;
1372         }
1373
1374         if (cxix >= 0) {
1375             I32 optype;
1376
1377             if (cxix < cxstack_ix)
1378                 dounwind(cxix);
1379
1380             POPBLOCK(cx,PL_curpm);
1381             if (CxTYPE(cx) != CXt_EVAL) {
1382                 if (!message)
1383                     message = SvPVx(ERRSV, msglen);
1384                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1385                 PerlIO_write(Perl_error_log, message, msglen);
1386                 my_exit(1);
1387             }
1388             POPEVAL(cx);
1389
1390             if (gimme == G_SCALAR)
1391                 *++newsp = &PL_sv_undef;
1392             PL_stack_sp = newsp;
1393
1394             LEAVE;
1395
1396             /* LEAVE could clobber PL_curcop (see save_re_context())
1397              * XXX it might be better to find a way to avoid messing with
1398              * PL_curcop in save_re_context() instead, but this is a more
1399              * minimal fix --GSAR */
1400             PL_curcop = cx->blk_oldcop;
1401
1402             if (optype == OP_REQUIRE) {
1403                 char* msg = SvPVx(ERRSV, n_a);
1404                SV *nsv = cx->blk_eval.old_namesv;
1405                (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1406                                &PL_sv_undef, 0);
1407                 DIE(aTHX_ "%sCompilation failed in require",
1408                     *msg ? msg : "Unknown error\n");
1409             }
1410             return pop_return();
1411         }
1412     }
1413     if (!message)
1414         message = SvPVx(ERRSV, msglen);
1415
1416     write_to_stderr(message, msglen);
1417     my_failure_exit();
1418     /* NOTREACHED */
1419     return 0;
1420 }
1421
1422 PP(pp_xor)
1423 {
1424     dSP; dPOPTOPssrl;
1425     if (SvTRUE(left) != SvTRUE(right))
1426         RETSETYES;
1427     else
1428         RETSETNO;
1429 }
1430
1431 PP(pp_andassign)
1432 {
1433     dSP;
1434     if (!SvTRUE(TOPs))
1435         RETURN;
1436     else
1437         RETURNOP(cLOGOP->op_other);
1438 }
1439
1440 PP(pp_orassign)
1441 {
1442     dSP;
1443     if (SvTRUE(TOPs))
1444         RETURN;
1445     else
1446         RETURNOP(cLOGOP->op_other);
1447 }
1448
1449 PP(pp_dorassign)
1450 {
1451     dSP;
1452     register SV* sv;
1453
1454     sv = TOPs;
1455     if (!sv || !SvANY(sv)) {
1456         RETURNOP(cLOGOP->op_other);
1457     }
1458
1459     switch (SvTYPE(sv)) {
1460     case SVt_PVAV:
1461         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1462             RETURN;
1463         break;
1464     case SVt_PVHV:
1465         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1466             RETURN;
1467         break;
1468     case SVt_PVCV:
1469         if (CvROOT(sv) || CvXSUB(sv))
1470             RETURN;
1471         break;
1472     default:
1473         if (SvGMAGICAL(sv))
1474             mg_get(sv);
1475         if (SvOK(sv))
1476             RETURN;
1477     }
1478
1479     RETURNOP(cLOGOP->op_other);
1480 }
1481
1482 PP(pp_caller)
1483 {
1484     dSP;
1485     register I32 cxix = dopoptosub(cxstack_ix);
1486     register PERL_CONTEXT *cx;
1487     register PERL_CONTEXT *ccstack = cxstack;
1488     PERL_SI *top_si = PL_curstackinfo;
1489     I32 dbcxix;
1490     I32 gimme;
1491     char *stashname;
1492     SV *sv;
1493     I32 count = 0;
1494
1495     if (MAXARG)
1496         count = POPi;
1497
1498     for (;;) {
1499         /* we may be in a higher stacklevel, so dig down deeper */
1500         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1501             top_si = top_si->si_prev;
1502             ccstack = top_si->si_cxstack;
1503             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1504         }
1505         if (cxix < 0) {
1506             if (GIMME != G_ARRAY) {
1507                 EXTEND(SP, 1);
1508                 RETPUSHUNDEF;
1509             }
1510             RETURN;
1511         }
1512         if (PL_DBsub && cxix >= 0 &&
1513                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1514             count++;
1515         if (!count--)
1516             break;
1517         cxix = dopoptosub_at(ccstack, cxix - 1);
1518     }
1519
1520     cx = &ccstack[cxix];
1521     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1522         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1523         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1524            field below is defined for any cx. */
1525         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1526             cx = &ccstack[dbcxix];
1527     }
1528
1529     stashname = CopSTASHPV(cx->blk_oldcop);
1530     if (GIMME != G_ARRAY) {
1531         EXTEND(SP, 1);
1532         if (!stashname)
1533             PUSHs(&PL_sv_undef);
1534         else {
1535             dTARGET;
1536             sv_setpv(TARG, stashname);
1537             PUSHs(TARG);
1538         }
1539         RETURN;
1540     }
1541
1542     EXTEND(SP, 10);
1543
1544     if (!stashname)
1545         PUSHs(&PL_sv_undef);
1546     else
1547         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1548     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1549     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1550     if (!MAXARG)
1551         RETURN;
1552     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1553         GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1554         /* So is ccstack[dbcxix]. */
1555         if (isGV(cvgv)) {
1556             sv = NEWSV(49, 0);
1557             gv_efullname3(sv, cvgv, Nullch);
1558             PUSHs(sv_2mortal(sv));
1559             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1560         }
1561         else {
1562             PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1563             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1564         }
1565     }
1566     else {
1567         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1568         PUSHs(sv_2mortal(newSViv(0)));
1569     }
1570     gimme = (I32)cx->blk_gimme;
1571     if (gimme == G_VOID)
1572         PUSHs(&PL_sv_undef);
1573     else
1574         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1575     if (CxTYPE(cx) == CXt_EVAL) {
1576         /* eval STRING */
1577         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1578             PUSHs(cx->blk_eval.cur_text);
1579             PUSHs(&PL_sv_no);
1580         }
1581         /* require */
1582         else if (cx->blk_eval.old_namesv) {
1583             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1584             PUSHs(&PL_sv_yes);
1585         }
1586         /* eval BLOCK (try blocks have old_namesv == 0) */
1587         else {
1588             PUSHs(&PL_sv_undef);
1589             PUSHs(&PL_sv_undef);
1590         }
1591     }
1592     else {
1593         PUSHs(&PL_sv_undef);
1594         PUSHs(&PL_sv_undef);
1595     }
1596     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1597         && CopSTASH_eq(PL_curcop, PL_debstash))
1598     {
1599         AV *ary = cx->blk_sub.argarray;
1600         int off = AvARRAY(ary) - AvALLOC(ary);
1601
1602         if (!PL_dbargs) {
1603             GV* tmpgv;
1604             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1605                                 SVt_PVAV)));
1606             GvMULTI_on(tmpgv);
1607             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1608         }
1609
1610         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1611             av_extend(PL_dbargs, AvFILLp(ary) + off);
1612         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1613         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1614     }
1615     /* XXX only hints propagated via op_private are currently
1616      * visible (others are not easily accessible, since they
1617      * use the global PL_hints) */
1618     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1619                              HINT_PRIVATE_MASK)));
1620     {
1621         SV * mask ;
1622         SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1623
1624         if  (old_warnings == pWARN_NONE ||
1625                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1626             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1627         else if (old_warnings == pWARN_ALL ||
1628                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1629             /* Get the bit mask for $warnings::Bits{all}, because
1630              * it could have been extended by warnings::register */
1631             SV **bits_all;
1632             HV *bits = get_hv("warnings::Bits", FALSE);
1633             if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1634                 mask = newSVsv(*bits_all);
1635             }
1636             else {
1637                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1638             }
1639         }
1640         else
1641             mask = newSVsv(old_warnings);
1642         PUSHs(sv_2mortal(mask));
1643     }
1644     RETURN;
1645 }
1646
1647 PP(pp_reset)
1648 {
1649     dSP;
1650     char *tmps;
1651     STRLEN n_a;
1652
1653     if (MAXARG < 1)
1654         tmps = "";
1655     else
1656         tmps = POPpx;
1657     sv_reset(tmps, CopSTASH(PL_curcop));
1658     PUSHs(&PL_sv_yes);
1659     RETURN;
1660 }
1661
1662 PP(pp_lineseq)
1663 {
1664     return NORMAL;
1665 }
1666
1667 /* like pp_nextstate, but used instead when the debugger is active */
1668
1669 PP(pp_dbstate)
1670 {
1671     PL_curcop = (COP*)PL_op;
1672     TAINT_NOT;          /* Each statement is presumed innocent */
1673     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1674     FREETMPS;
1675
1676     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1677             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1678     {
1679         dSP;
1680         register CV *cv;
1681         register PERL_CONTEXT *cx;
1682         I32 gimme = G_ARRAY;
1683         U8 hasargs;
1684         GV *gv;
1685
1686         gv = PL_DBgv;
1687         cv = GvCV(gv);
1688         if (!cv)
1689             DIE(aTHX_ "No DB::DB routine defined");
1690
1691         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1692             /* don't do recursive DB::DB call */
1693             return NORMAL;
1694
1695         ENTER;
1696         SAVETMPS;
1697
1698         SAVEI32(PL_debug);
1699         SAVESTACK_POS();
1700         PL_debug = 0;
1701         hasargs = 0;
1702         SPAGAIN;
1703
1704         push_return(PL_op->op_next);
1705         PUSHBLOCK(cx, CXt_SUB, SP);
1706         PUSHSUB_DB(cx);
1707         CvDEPTH(cv)++;
1708         (void)SvREFCNT_inc(cv);
1709         PAD_SET_CUR(CvPADLIST(cv),1);
1710         RETURNOP(CvSTART(cv));
1711     }
1712     else
1713         return NORMAL;
1714 }
1715
1716 PP(pp_scope)
1717 {
1718     return NORMAL;
1719 }
1720
1721 PP(pp_enteriter)
1722 {
1723     dSP; dMARK;
1724     register PERL_CONTEXT *cx;
1725     I32 gimme = GIMME_V;
1726     SV **svp;
1727     U32 cxtype = CXt_LOOP;
1728 #ifdef USE_ITHREADS
1729     void *iterdata;
1730 #endif
1731
1732     ENTER;
1733     SAVETMPS;
1734
1735     if (PL_op->op_targ) {
1736         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1737             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1738             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1739                     SVs_PADSTALE, SVs_PADSTALE);
1740         }
1741 #ifndef USE_ITHREADS
1742         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1743         SAVESPTR(*svp);
1744 #else
1745         SAVEPADSV(PL_op->op_targ);
1746         iterdata = INT2PTR(void*, PL_op->op_targ);
1747         cxtype |= CXp_PADVAR;
1748 #endif
1749     }
1750     else {
1751         GV *gv = (GV*)POPs;
1752         svp = &GvSV(gv);                        /* symbol table variable */
1753         SAVEGENERICSV(*svp);
1754         *svp = NEWSV(0,0);
1755 #ifdef USE_ITHREADS
1756         iterdata = (void*)gv;
1757 #endif
1758     }
1759
1760     ENTER;
1761
1762     PUSHBLOCK(cx, cxtype, SP);
1763 #ifdef USE_ITHREADS
1764     PUSHLOOP(cx, iterdata, MARK);
1765 #else
1766     PUSHLOOP(cx, svp, MARK);
1767 #endif
1768     if (PL_op->op_flags & OPf_STACKED) {
1769         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1770         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1771             dPOPss;
1772             /* See comment in pp_flop() */
1773             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1774                 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1775                 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1776                  looks_like_number((SV*)cx->blk_loop.iterary)))
1777             {
1778                  if (SvNV(sv) < IV_MIN ||
1779                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1780                      DIE(aTHX_ "Range iterator outside integer range");
1781                  cx->blk_loop.iterix = SvIV(sv);
1782                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1783             }
1784             else
1785                 cx->blk_loop.iterlval = newSVsv(sv);
1786         }
1787     }
1788     else {
1789         cx->blk_loop.iterary = PL_curstack;
1790         AvFILLp(PL_curstack) = SP - PL_stack_base;
1791         cx->blk_loop.iterix = MARK - PL_stack_base;
1792     }
1793
1794     RETURN;
1795 }
1796
1797 PP(pp_enterloop)
1798 {
1799     dSP;
1800     register PERL_CONTEXT *cx;
1801     I32 gimme = GIMME_V;
1802
1803     ENTER;
1804     SAVETMPS;
1805     ENTER;
1806
1807     PUSHBLOCK(cx, CXt_LOOP, SP);
1808     PUSHLOOP(cx, 0, SP);
1809
1810     RETURN;
1811 }
1812
1813 PP(pp_leaveloop)
1814 {
1815     dSP;
1816     register PERL_CONTEXT *cx;
1817     I32 gimme;
1818     SV **newsp;
1819     PMOP *newpm;
1820     SV **mark;
1821
1822     POPBLOCK(cx,newpm);
1823     mark = newsp;
1824     newsp = PL_stack_base + cx->blk_loop.resetsp;
1825
1826     TAINT_NOT;
1827     if (gimme == G_VOID)
1828         ; /* do nothing */
1829     else if (gimme == G_SCALAR) {
1830         if (mark < SP)
1831             *++newsp = sv_mortalcopy(*SP);
1832         else
1833             *++newsp = &PL_sv_undef;
1834     }
1835     else {
1836         while (mark < SP) {
1837             *++newsp = sv_mortalcopy(*++mark);
1838             TAINT_NOT;          /* Each item is independent */
1839         }
1840     }
1841     SP = newsp;
1842     PUTBACK;
1843
1844     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1845     PL_curpm = newpm;   /* ... and pop $1 et al */
1846
1847     LEAVE;
1848     LEAVE;
1849
1850     return NORMAL;
1851 }
1852
1853 PP(pp_return)
1854 {
1855     dSP; dMARK;
1856     I32 cxix;
1857     register PERL_CONTEXT *cx;
1858     bool popsub2 = FALSE;
1859     bool clear_errsv = FALSE;
1860     I32 gimme;
1861     SV **newsp;
1862     PMOP *newpm;
1863     I32 optype = 0;
1864     SV *sv;
1865
1866     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1867         if (cxstack_ix == PL_sortcxix
1868             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1869         {
1870             if (cxstack_ix > PL_sortcxix)
1871                 dounwind(PL_sortcxix);
1872             AvARRAY(PL_curstack)[1] = *SP;
1873             PL_stack_sp = PL_stack_base + 1;
1874             return 0;
1875         }
1876     }
1877
1878     cxix = dopoptosub(cxstack_ix);
1879     if (cxix < 0)
1880         DIE(aTHX_ "Can't return outside a subroutine");
1881     if (cxix < cxstack_ix)
1882         dounwind(cxix);
1883
1884     POPBLOCK(cx,newpm);
1885     switch (CxTYPE(cx)) {
1886     case CXt_SUB:
1887         popsub2 = TRUE;
1888         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1889         break;
1890     case CXt_EVAL:
1891         if (!(PL_in_eval & EVAL_KEEPERR))
1892             clear_errsv = TRUE;
1893         POPEVAL(cx);
1894         if (CxTRYBLOCK(cx))
1895             break;
1896         lex_end();
1897         if (optype == OP_REQUIRE &&
1898             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1899         {
1900             /* Unassume the success we assumed earlier. */
1901             SV *nsv = cx->blk_eval.old_namesv;
1902             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1903             DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1904         }
1905         break;
1906     case CXt_FORMAT:
1907         POPFORMAT(cx);
1908         break;
1909     default:
1910         DIE(aTHX_ "panic: return");
1911     }
1912
1913     TAINT_NOT;
1914     if (gimme == G_SCALAR) {
1915         if (MARK < SP) {
1916             if (popsub2) {
1917                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1918                     if (SvTEMP(TOPs)) {
1919                         *++newsp = SvREFCNT_inc(*SP);
1920                         FREETMPS;
1921                         sv_2mortal(*newsp);
1922                     }
1923                     else {
1924                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1925                         FREETMPS;
1926                         *++newsp = sv_mortalcopy(sv);
1927                         SvREFCNT_dec(sv);
1928                     }
1929                 }
1930                 else
1931                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1932             }
1933             else
1934                 *++newsp = sv_mortalcopy(*SP);
1935         }
1936         else
1937             *++newsp = &PL_sv_undef;
1938     }
1939     else if (gimme == G_ARRAY) {
1940         while (++MARK <= SP) {
1941             *++newsp = (popsub2 && SvTEMP(*MARK))
1942                         ? *MARK : sv_mortalcopy(*MARK);
1943             TAINT_NOT;          /* Each item is independent */
1944         }
1945     }
1946     PL_stack_sp = newsp;
1947
1948     LEAVE;
1949     /* Stack values are safe: */
1950     if (popsub2) {
1951         cxstack_ix--;
1952         POPSUB(cx,sv);  /* release CV and @_ ... */
1953     }
1954     else
1955         sv = Nullsv;
1956     PL_curpm = newpm;   /* ... and pop $1 et al */
1957
1958     LEAVESUB(sv);
1959     if (clear_errsv)
1960         sv_setpv(ERRSV,"");
1961     return pop_return();
1962 }
1963
1964 PP(pp_last)
1965 {
1966     dSP;
1967     I32 cxix;
1968     register PERL_CONTEXT *cx;
1969     I32 pop2 = 0;
1970     I32 gimme;
1971     I32 optype;
1972     OP *nextop;
1973     SV **newsp;
1974     PMOP *newpm;
1975     SV **mark;
1976     SV *sv = Nullsv;
1977
1978     if (PL_op->op_flags & OPf_SPECIAL) {
1979         cxix = dopoptoloop(cxstack_ix);
1980         if (cxix < 0)
1981             DIE(aTHX_ "Can't \"last\" outside a loop block");
1982     }
1983     else {
1984         cxix = dopoptolabel(cPVOP->op_pv);
1985         if (cxix < 0)
1986             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1987     }
1988     if (cxix < cxstack_ix)
1989         dounwind(cxix);
1990
1991     POPBLOCK(cx,newpm);
1992     cxstack_ix++; /* temporarily protect top context */
1993     mark = newsp;
1994     switch (CxTYPE(cx)) {
1995     case CXt_LOOP:
1996         pop2 = CXt_LOOP;
1997         newsp = PL_stack_base + cx->blk_loop.resetsp;
1998         nextop = cx->blk_loop.last_op->op_next;
1999         break;
2000     case CXt_SUB:
2001         pop2 = CXt_SUB;
2002         nextop = pop_return();
2003         break;
2004     case CXt_EVAL:
2005         POPEVAL(cx);
2006         nextop = pop_return();
2007         break;
2008     case CXt_FORMAT:
2009         POPFORMAT(cx);
2010         nextop = pop_return();
2011         break;
2012     default:
2013         DIE(aTHX_ "panic: last");
2014     }
2015
2016     TAINT_NOT;
2017     if (gimme == G_SCALAR) {
2018         if (MARK < SP)
2019             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2020                         ? *SP : sv_mortalcopy(*SP);
2021         else
2022             *++newsp = &PL_sv_undef;
2023     }
2024     else if (gimme == G_ARRAY) {
2025         while (++MARK <= SP) {
2026             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2027                         ? *MARK : sv_mortalcopy(*MARK);
2028             TAINT_NOT;          /* Each item is independent */
2029         }
2030     }
2031     SP = newsp;
2032     PUTBACK;
2033
2034     LEAVE;
2035     cxstack_ix--;
2036     /* Stack values are safe: */
2037     switch (pop2) {
2038     case CXt_LOOP:
2039         POPLOOP(cx);    /* release loop vars ... */
2040         LEAVE;
2041         break;
2042     case CXt_SUB:
2043         POPSUB(cx,sv);  /* release CV and @_ ... */
2044         break;
2045     }
2046     PL_curpm = newpm;   /* ... and pop $1 et al */
2047
2048     LEAVESUB(sv);
2049     return nextop;
2050 }
2051
2052 PP(pp_next)
2053 {
2054     I32 cxix;
2055     register PERL_CONTEXT *cx;
2056     I32 inner;
2057
2058     if (PL_op->op_flags & OPf_SPECIAL) {
2059         cxix = dopoptoloop(cxstack_ix);
2060         if (cxix < 0)
2061             DIE(aTHX_ "Can't \"next\" outside a loop block");
2062     }
2063     else {
2064         cxix = dopoptolabel(cPVOP->op_pv);
2065         if (cxix < 0)
2066             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2067     }
2068     if (cxix < cxstack_ix)
2069         dounwind(cxix);
2070
2071     /* clear off anything above the scope we're re-entering, but
2072      * save the rest until after a possible continue block */
2073     inner = PL_scopestack_ix;
2074     TOPBLOCK(cx);
2075     if (PL_scopestack_ix < inner)
2076         leave_scope(PL_scopestack[PL_scopestack_ix]);
2077     return cx->blk_loop.next_op;
2078 }
2079
2080 PP(pp_redo)
2081 {
2082     I32 cxix;
2083     register PERL_CONTEXT *cx;
2084     I32 oldsave;
2085
2086     if (PL_op->op_flags & OPf_SPECIAL) {
2087         cxix = dopoptoloop(cxstack_ix);
2088         if (cxix < 0)
2089             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2090     }
2091     else {
2092         cxix = dopoptolabel(cPVOP->op_pv);
2093         if (cxix < 0)
2094             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2095     }
2096     if (cxix < cxstack_ix)
2097         dounwind(cxix);
2098
2099     TOPBLOCK(cx);
2100     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2101     LEAVE_SCOPE(oldsave);
2102     return cx->blk_loop.redo_op;
2103 }
2104
2105 STATIC OP *
2106 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2107 {
2108     OP *kid = Nullop;
2109     OP **ops = opstack;
2110     static char too_deep[] = "Target of goto is too deeply nested";
2111
2112     if (ops >= oplimit)
2113         Perl_croak(aTHX_ too_deep);
2114     if (o->op_type == OP_LEAVE ||
2115         o->op_type == OP_SCOPE ||
2116         o->op_type == OP_LEAVELOOP ||
2117         o->op_type == OP_LEAVESUB ||
2118         o->op_type == OP_LEAVETRY)
2119     {
2120         *ops++ = cUNOPo->op_first;
2121         if (ops >= oplimit)
2122             Perl_croak(aTHX_ too_deep);
2123     }
2124     *ops = 0;
2125     if (o->op_flags & OPf_KIDS) {
2126         /* First try all the kids at this level, since that's likeliest. */
2127         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2128             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2129                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2130                 return kid;
2131         }
2132         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2133             if (kid == PL_lastgotoprobe)
2134                 continue;
2135             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2136                 if (ops == opstack)
2137                     *ops++ = kid;
2138                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2139                          ops[-1]->op_type == OP_DBSTATE)
2140                     ops[-1] = kid;
2141                 else
2142                     *ops++ = kid;
2143             }
2144             if ((o = dofindlabel(kid, label, ops, oplimit)))
2145                 return o;
2146         }
2147     }
2148     *ops = 0;
2149     return 0;
2150 }
2151
2152 PP(pp_dump)
2153 {
2154     return pp_goto();
2155     /*NOTREACHED*/
2156 }
2157
2158 PP(pp_goto)
2159 {
2160     dSP;
2161     OP *retop = 0;
2162     I32 ix;
2163     register PERL_CONTEXT *cx;
2164 #define GOTO_DEPTH 64
2165     OP *enterops[GOTO_DEPTH];
2166     char *label;
2167     int do_dump = (PL_op->op_type == OP_DUMP);
2168     static char must_have_label[] = "goto must have label";
2169
2170     label = 0;
2171     if (PL_op->op_flags & OPf_STACKED) {
2172         SV *sv = POPs;
2173         STRLEN n_a;
2174
2175         /* This egregious kludge implements goto &subroutine */
2176         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2177             I32 cxix;
2178             register PERL_CONTEXT *cx;
2179             CV* cv = (CV*)SvRV(sv);
2180             SV** mark;
2181             I32 items = 0;
2182             I32 oldsave;
2183
2184         retry:
2185             if (!CvROOT(cv) && !CvXSUB(cv)) {
2186                 GV *gv = CvGV(cv);
2187                 GV *autogv;
2188                 if (gv) {
2189                     SV *tmpstr;
2190                     /* autoloaded stub? */
2191                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2192                         goto retry;
2193                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2194                                           GvNAMELEN(gv), FALSE);
2195                     if (autogv && (cv = GvCV(autogv)))
2196                         goto retry;
2197                     tmpstr = sv_newmortal();
2198                     gv_efullname3(tmpstr, gv, Nullch);
2199                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2200                 }
2201                 DIE(aTHX_ "Goto undefined subroutine");
2202             }
2203
2204             /* First do some returnish stuff. */
2205             SvREFCNT_inc(cv); /* avoid premature free during unwind */
2206             FREETMPS;
2207             cxix = dopoptosub(cxstack_ix);
2208             if (cxix < 0)
2209                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2210             if (cxix < cxstack_ix)
2211                 dounwind(cxix);
2212             TOPBLOCK(cx);
2213             if (CxREALEVAL(cx))
2214                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2215             mark = PL_stack_sp;
2216             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2217                 /* put @_ back onto stack */
2218                 AV* av = cx->blk_sub.argarray;
2219
2220                 items = AvFILLp(av) + 1;
2221                 PL_stack_sp++;
2222                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2223                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2224                 PL_stack_sp += items;
2225                 SvREFCNT_dec(GvAV(PL_defgv));
2226                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2227                 /* abandon @_ if it got reified */
2228                 if (AvREAL(av)) {
2229                     (void)sv_2mortal((SV*)av);  /* delay until return */
2230                     av = newAV();
2231                     av_extend(av, items-1);
2232                     AvFLAGS(av) = AVf_REIFY;
2233                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2234                 }
2235                 else
2236                     CLEAR_ARGARRAY(av);
2237             }
2238             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2239                 AV* av;
2240                 av = GvAV(PL_defgv);
2241                 items = AvFILLp(av) + 1;
2242                 PL_stack_sp++;
2243                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2244                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2245                 PL_stack_sp += items;
2246             }
2247             if (CxTYPE(cx) == CXt_SUB &&
2248                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2249                 SvREFCNT_dec(cx->blk_sub.cv);
2250             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2251             LEAVE_SCOPE(oldsave);
2252
2253             /* Now do some callish stuff. */
2254             SAVETMPS;
2255             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2256             if (CvXSUB(cv)) {
2257 #ifdef PERL_XSUB_OLDSTYLE
2258                 if (CvOLDSTYLE(cv)) {
2259                     I32 (*fp3)(int,int,int);
2260                     while (SP > mark) {
2261                         SP[1] = SP[0];
2262                         SP--;
2263                     }
2264                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2265                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2266                                    mark - PL_stack_base + 1,
2267                                    items);
2268                     SP = PL_stack_base + items;
2269                 }
2270                 else
2271 #endif /* PERL_XSUB_OLDSTYLE */
2272                 {
2273                     SV **newsp;
2274                     I32 gimme;
2275
2276                     PL_stack_sp--;              /* There is no cv arg. */
2277                     /* Push a mark for the start of arglist */
2278                     PUSHMARK(mark);
2279                     (void)(*CvXSUB(cv))(aTHX_ cv);
2280                     /* Pop the current context like a decent sub should */
2281                     POPBLOCK(cx, PL_curpm);
2282                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2283                 }
2284                 LEAVE;
2285                 return pop_return();
2286             }
2287             else {
2288                 AV* padlist = CvPADLIST(cv);
2289                 if (CxTYPE(cx) == CXt_EVAL) {
2290                     PL_in_eval = cx->blk_eval.old_in_eval;
2291                     PL_eval_root = cx->blk_eval.old_eval_root;
2292                     cx->cx_type = CXt_SUB;
2293                     cx->blk_sub.hasargs = 0;
2294                 }
2295                 cx->blk_sub.cv = cv;
2296                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2297
2298                 CvDEPTH(cv)++;
2299                 if (CvDEPTH(cv) < 2)
2300                     (void)SvREFCNT_inc(cv);
2301                 else {
2302                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2303                         sub_crush_depth(cv);
2304                     pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2305                 }
2306                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2307                 if (cx->blk_sub.hasargs)
2308                 {
2309                     AV* av = (AV*)PAD_SVl(0);
2310                     SV** ary;
2311
2312                     cx->blk_sub.savearray = GvAV(PL_defgv);
2313                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2314                     CX_CURPAD_SAVE(cx->blk_sub);
2315                     cx->blk_sub.argarray = av;
2316                     ++mark;
2317
2318                     if (items >= AvMAX(av) + 1) {
2319                         ary = AvALLOC(av);
2320                         if (AvARRAY(av) != ary) {
2321                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2322                             SvPVX(av) = (char*)ary;
2323                         }
2324                         if (items >= AvMAX(av) + 1) {
2325                             AvMAX(av) = items - 1;
2326                             Renew(ary,items+1,SV*);
2327                             AvALLOC(av) = ary;
2328                             SvPVX(av) = (char*)ary;
2329                         }
2330                     }
2331                     Copy(mark,AvARRAY(av),items,SV*);
2332                     AvFILLp(av) = items - 1;
2333                     assert(!AvREAL(av));
2334                     while (items--) {
2335                         if (*mark)
2336                             SvTEMP_off(*mark);
2337                         mark++;
2338                     }
2339                 }
2340                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2341                     /*
2342                      * We do not care about using sv to call CV;
2343                      * it's for informational purposes only.
2344                      */
2345                     SV *sv = GvSV(PL_DBsub);
2346                     CV *gotocv;
2347
2348                     if (PERLDB_SUB_NN) {
2349                         (void)SvUPGRADE(sv, SVt_PVIV);
2350                         (void)SvIOK_on(sv);
2351                         SAVEIV(SvIVX(sv));
2352                         SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2353                     } else {
2354                         save_item(sv);
2355                         gv_efullname3(sv, CvGV(cv), Nullch);
2356                     }
2357                     if (  PERLDB_GOTO
2358                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2359                         PUSHMARK( PL_stack_sp );
2360                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2361                         PL_stack_sp--;
2362                     }
2363                 }
2364                 RETURNOP(CvSTART(cv));
2365             }
2366         }
2367         else {
2368             label = SvPV(sv,n_a);
2369             if (!(do_dump || *label))
2370                 DIE(aTHX_ must_have_label);
2371         }
2372     }
2373     else if (PL_op->op_flags & OPf_SPECIAL) {
2374         if (! do_dump)
2375             DIE(aTHX_ must_have_label);
2376     }
2377     else
2378         label = cPVOP->op_pv;
2379
2380     if (label && *label) {
2381         OP *gotoprobe = 0;
2382         bool leaving_eval = FALSE;
2383         bool in_block = FALSE;
2384         PERL_CONTEXT *last_eval_cx = 0;
2385
2386         /* find label */
2387
2388         PL_lastgotoprobe = 0;
2389         *enterops = 0;
2390         for (ix = cxstack_ix; ix >= 0; ix--) {
2391             cx = &cxstack[ix];
2392             switch (CxTYPE(cx)) {
2393             case CXt_EVAL:
2394                 leaving_eval = TRUE;
2395                 if (!CxTRYBLOCK(cx)) {
2396                     gotoprobe = (last_eval_cx ?
2397                                 last_eval_cx->blk_eval.old_eval_root :
2398                                 PL_eval_root);
2399                     last_eval_cx = cx;
2400                     break;
2401                 }
2402                 /* else fall through */
2403             case CXt_LOOP:
2404                 gotoprobe = cx->blk_oldcop->op_sibling;
2405                 break;
2406             case CXt_SUBST:
2407                 continue;
2408             case CXt_BLOCK:
2409                 if (ix) {
2410                     gotoprobe = cx->blk_oldcop->op_sibling;
2411                     in_block = TRUE;
2412                 } else
2413                     gotoprobe = PL_main_root;
2414                 break;
2415             case CXt_SUB:
2416                 if (CvDEPTH(cx->blk_sub.cv)) {
2417                     gotoprobe = CvROOT(cx->blk_sub.cv);
2418                     break;
2419                 }
2420                 /* FALL THROUGH */
2421             case CXt_FORMAT:
2422             case CXt_NULL:
2423                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2424             default:
2425                 if (ix)
2426                     DIE(aTHX_ "panic: goto");
2427                 gotoprobe = PL_main_root;
2428                 break;
2429             }
2430             if (gotoprobe) {
2431                 retop = dofindlabel(gotoprobe, label,
2432                                     enterops, enterops + GOTO_DEPTH);
2433                 if (retop)
2434                     break;
2435             }
2436             PL_lastgotoprobe = gotoprobe;
2437         }
2438         if (!retop)
2439             DIE(aTHX_ "Can't find label %s", label);
2440
2441         /* if we're leaving an eval, check before we pop any frames
2442            that we're not going to punt, otherwise the error
2443            won't be caught */
2444
2445         if (leaving_eval && *enterops && enterops[1]) {
2446             I32 i;
2447             for (i = 1; enterops[i]; i++)
2448                 if (enterops[i]->op_type == OP_ENTERITER)
2449                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2450         }
2451
2452         /* pop unwanted frames */
2453
2454         if (ix < cxstack_ix) {
2455             I32 oldsave;
2456
2457             if (ix < 0)
2458                 ix = 0;
2459             dounwind(ix);
2460             TOPBLOCK(cx);
2461             oldsave = PL_scopestack[PL_scopestack_ix];
2462             LEAVE_SCOPE(oldsave);
2463         }
2464
2465         /* push wanted frames */
2466
2467         if (*enterops && enterops[1]) {
2468             OP *oldop = PL_op;
2469             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2470             for (; enterops[ix]; ix++) {
2471                 PL_op = enterops[ix];
2472                 /* Eventually we may want to stack the needed arguments
2473                  * for each op.  For now, we punt on the hard ones. */
2474                 if (PL_op->op_type == OP_ENTERITER)
2475                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2476                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2477             }
2478             PL_op = oldop;
2479         }
2480     }
2481
2482     if (do_dump) {
2483 #ifdef VMS
2484         if (!retop) retop = PL_main_start;
2485 #endif
2486         PL_restartop = retop;
2487         PL_do_undump = TRUE;
2488
2489         my_unexec();
2490
2491         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2492         PL_do_undump = FALSE;
2493     }
2494
2495     RETURNOP(retop);
2496 }
2497
2498 PP(pp_exit)
2499 {
2500     dSP;
2501     I32 anum;
2502
2503     if (MAXARG < 1)
2504         anum = 0;
2505     else {
2506         anum = SvIVx(POPs);
2507 #ifdef VMS
2508         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2509             anum = 0;
2510         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2511 #endif
2512     }
2513     PL_exit_flags |= PERL_EXIT_EXPECTED;
2514     my_exit(anum);
2515     PUSHs(&PL_sv_undef);
2516     RETURN;
2517 }
2518
2519 #ifdef NOTYET
2520 PP(pp_nswitch)
2521 {
2522     dSP;
2523     NV value = SvNVx(GvSV(cCOP->cop_gv));
2524     register I32 match = I_32(value);
2525
2526     if (value < 0.0) {
2527         if (((NV)match) > value)
2528             --match;            /* was fractional--truncate other way */
2529     }
2530     match -= cCOP->uop.scop.scop_offset;
2531     if (match < 0)
2532         match = 0;
2533     else if (match > cCOP->uop.scop.scop_max)
2534         match = cCOP->uop.scop.scop_max;
2535     PL_op = cCOP->uop.scop.scop_next[match];
2536     RETURNOP(PL_op);
2537 }
2538
2539 PP(pp_cswitch)
2540 {
2541     dSP;
2542     register I32 match;
2543
2544     if (PL_multiline)
2545         PL_op = PL_op->op_next;                 /* can't assume anything */
2546     else {
2547         STRLEN n_a;
2548         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2549         match -= cCOP->uop.scop.scop_offset;
2550         if (match < 0)
2551             match = 0;
2552         else if (match > cCOP->uop.scop.scop_max)
2553             match = cCOP->uop.scop.scop_max;
2554         PL_op = cCOP->uop.scop.scop_next[match];
2555     }
2556     RETURNOP(PL_op);
2557 }
2558 #endif
2559
2560 /* Eval. */
2561
2562 STATIC void
2563 S_save_lines(pTHX_ AV *array, SV *sv)
2564 {
2565     register char *s = SvPVX(sv);
2566     register char *send = SvPVX(sv) + SvCUR(sv);
2567     register char *t;
2568     register I32 line = 1;
2569
2570     while (s && s < send) {
2571         SV *tmpstr = NEWSV(85,0);
2572
2573         sv_upgrade(tmpstr, SVt_PVMG);
2574         t = strchr(s, '\n');
2575         if (t)
2576             t++;
2577         else
2578             t = send;
2579
2580         sv_setpvn(tmpstr, s, t - s);
2581         av_store(array, line++, tmpstr);
2582         s = t;
2583     }
2584 }
2585
2586 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2587 STATIC void *
2588 S_docatch_body(pTHX_ va_list args)
2589 {
2590     return docatch_body();
2591 }
2592 #endif
2593
2594 STATIC void *
2595 S_docatch_body(pTHX)
2596 {
2597     CALLRUNOPS(aTHX);
2598     return NULL;
2599 }
2600
2601 STATIC OP *
2602 S_docatch(pTHX_ OP *o)
2603 {
2604     int ret;
2605     OP *oldop = PL_op;
2606     OP *retop;
2607     volatile PERL_SI *cursi = PL_curstackinfo;
2608     dJMPENV;
2609
2610 #ifdef DEBUGGING
2611     assert(CATCH_GET == TRUE);
2612 #endif
2613     PL_op = o;
2614
2615     /* Normally, the leavetry at the end of this block of ops will
2616      * pop an op off the return stack and continue there. By setting
2617      * the op to Nullop, we force an exit from the inner runops()
2618      * loop. DAPM.
2619      */
2620     retop = pop_return();
2621     push_return(Nullop);
2622
2623 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2624  redo_body:
2625     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2626 #else
2627     JMPENV_PUSH(ret);
2628 #endif
2629     switch (ret) {
2630     case 0:
2631 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2632  redo_body:
2633         docatch_body();
2634 #endif
2635         break;
2636     case 3:
2637         /* die caught by an inner eval - continue inner loop */
2638         if (PL_restartop && cursi == PL_curstackinfo) {
2639             PL_op = PL_restartop;
2640             PL_restartop = 0;
2641             goto redo_body;
2642         }
2643         /* a die in this eval - continue in outer loop */
2644         if (!PL_restartop)
2645             break;
2646         /* FALL THROUGH */
2647     default:
2648         JMPENV_POP;
2649         PL_op = oldop;
2650         JMPENV_JUMP(ret);
2651         /* NOTREACHED */
2652     }
2653     JMPENV_POP;
2654     PL_op = oldop;
2655     return retop;
2656 }
2657
2658 OP *
2659 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2660 /* sv Text to convert to OP tree. */
2661 /* startop op_free() this to undo. */
2662 /* code Short string id of the caller. */
2663 {
2664     dSP;                                /* Make POPBLOCK work. */
2665     PERL_CONTEXT *cx;
2666     SV **newsp;
2667     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2668     I32 optype;
2669     OP dummy;
2670     OP *rop;
2671     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2672     char *tmpbuf = tbuf;
2673     char *safestr;
2674     int runtime;
2675     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2676
2677     ENTER;
2678     lex_start(sv);
2679     SAVETMPS;
2680     /* switch to eval mode */
2681
2682     if (IN_PERL_COMPILETIME) {
2683         SAVECOPSTASH_FREE(&PL_compiling);
2684         CopSTASH_set(&PL_compiling, PL_curstash);
2685     }
2686     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2687         SV *sv = sv_newmortal();
2688         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2689                        code, (unsigned long)++PL_evalseq,
2690                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2691         tmpbuf = SvPVX(sv);
2692     }
2693     else
2694         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2695     SAVECOPFILE_FREE(&PL_compiling);
2696     CopFILE_set(&PL_compiling, tmpbuf+2);
2697     SAVECOPLINE(&PL_compiling);
2698     CopLINE_set(&PL_compiling, 1);
2699     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2700        deleting the eval's FILEGV from the stash before gv_check() runs
2701        (i.e. before run-time proper). To work around the coredump that
2702        ensues, we always turn GvMULTI_on for any globals that were
2703        introduced within evals. See force_ident(). GSAR 96-10-12 */
2704     safestr = savepv(tmpbuf);
2705     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2706     SAVEHINTS();
2707 #ifdef OP_IN_REGISTER
2708     PL_opsave = op;
2709 #else
2710     SAVEVPTR(PL_op);
2711 #endif
2712     PL_hints &= HINT_UTF8;
2713
2714     /* we get here either during compilation, or via pp_regcomp at runtime */
2715     runtime = IN_PERL_RUNTIME;
2716     if (runtime)
2717         runcv = find_runcv(NULL);
2718
2719     PL_op = &dummy;
2720     PL_op->op_type = OP_ENTEREVAL;
2721     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2722     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2723     PUSHEVAL(cx, 0, Nullgv);
2724
2725     if (runtime)
2726         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2727     else
2728         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2729     POPBLOCK(cx,PL_curpm);
2730     POPEVAL(cx);
2731
2732     (*startop)->op_type = OP_NULL;
2733     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2734     lex_end();
2735     /* XXX DAPM do this properly one year */
2736     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2737     LEAVE;
2738     if (IN_PERL_COMPILETIME)
2739         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2740 #ifdef OP_IN_REGISTER
2741     op = PL_opsave;
2742 #endif
2743     return rop;
2744 }
2745
2746
2747 /*
2748 =for apidoc find_runcv
2749
2750 Locate the CV corresponding to the currently executing sub or eval.
2751 If db_seqp is non_null, skip CVs that are in the DB package and populate
2752 *db_seqp with the cop sequence number at the point that the DB:: code was
2753 entered. (allows debuggers to eval in the scope of the breakpoint rather
2754 than in in the scope of the debuger itself).
2755
2756 =cut
2757 */
2758
2759 CV*
2760 Perl_find_runcv(pTHX_ U32 *db_seqp)
2761 {
2762     I32          ix;
2763     PERL_SI      *si;
2764     PERL_CONTEXT *cx;
2765
2766     if (db_seqp)
2767         *db_seqp = PL_curcop->cop_seq;
2768     for (si = PL_curstackinfo; si; si = si->si_prev) {
2769         for (ix = si->si_cxix; ix >= 0; ix--) {
2770             cx = &(si->si_cxstack[ix]);
2771             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2772                 CV *cv = cx->blk_sub.cv;
2773                 /* skip DB:: code */
2774                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2775                     *db_seqp = cx->blk_oldcop->cop_seq;
2776                     continue;
2777                 }
2778                 return cv;
2779             }
2780             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2781                 return PL_compcv;
2782         }
2783     }
2784     return PL_main_cv;
2785 }
2786
2787
2788 /* Compile a require/do, an eval '', or a /(?{...})/.
2789  * In the last case, startop is non-null, and contains the address of
2790  * a pointer that should be set to the just-compiled code.
2791  * outside is the lexically enclosing CV (if any) that invoked us.
2792  */
2793
2794 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2795 STATIC OP *
2796 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2797 {
2798     dSP;
2799     OP *saveop = PL_op;
2800
2801     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2802                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2803                   : EVAL_INEVAL);
2804
2805     PUSHMARK(SP);
2806
2807     SAVESPTR(PL_compcv);
2808     PL_compcv = (CV*)NEWSV(1104,0);
2809     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2810     CvEVAL_on(PL_compcv);
2811     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2812     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2813
2814     CvOUTSIDE_SEQ(PL_compcv) = seq;
2815     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2816
2817     /* set up a scratch pad */
2818
2819     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2820
2821
2822     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2823
2824     /* make sure we compile in the right package */
2825
2826     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2827         SAVESPTR(PL_curstash);
2828         PL_curstash = CopSTASH(PL_curcop);
2829     }
2830     SAVESPTR(PL_beginav);
2831     PL_beginav = newAV();
2832     SAVEFREESV(PL_beginav);
2833     SAVEI32(PL_error_count);
2834
2835     /* try to compile it */
2836
2837     PL_eval_root = Nullop;
2838     PL_error_count = 0;
2839     PL_curcop = &PL_compiling;
2840     PL_curcop->cop_arybase = 0;
2841     if (saveop && saveop->op_flags & OPf_SPECIAL)
2842         PL_in_eval |= EVAL_KEEPERR;
2843     else
2844         sv_setpv(ERRSV,"");
2845     if (yyparse() || PL_error_count || !PL_eval_root) {
2846         SV **newsp;                     /* Used by POPBLOCK. */
2847        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2848         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2849         STRLEN n_a;
2850
2851         PL_op = saveop;
2852         if (PL_eval_root) {
2853             op_free(PL_eval_root);
2854             PL_eval_root = Nullop;
2855         }
2856         SP = PL_stack_base + POPMARK;           /* pop original mark */
2857         if (!startop) {
2858             POPBLOCK(cx,PL_curpm);
2859             POPEVAL(cx);
2860             pop_return();
2861         }
2862         lex_end();
2863         LEAVE;
2864         if (optype == OP_REQUIRE) {
2865             char* msg = SvPVx(ERRSV, n_a);
2866            SV *nsv = cx->blk_eval.old_namesv;
2867            (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2868                           &PL_sv_undef, 0);
2869             DIE(aTHX_ "%sCompilation failed in require",
2870                 *msg ? msg : "Unknown error\n");
2871         }
2872         else if (startop) {
2873             char* msg = SvPVx(ERRSV, n_a);
2874
2875             POPBLOCK(cx,PL_curpm);
2876             POPEVAL(cx);
2877             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2878                        (*msg ? msg : "Unknown error\n"));
2879         }
2880         else {
2881             char* msg = SvPVx(ERRSV, n_a);
2882             if (!*msg) {
2883                 sv_setpv(ERRSV, "Compilation error");
2884             }
2885         }
2886         RETPUSHUNDEF;
2887     }
2888     CopLINE_set(&PL_compiling, 0);
2889     if (startop) {
2890         *startop = PL_eval_root;
2891     } else
2892         SAVEFREEOP(PL_eval_root);
2893
2894     /* Set the context for this new optree.
2895      * If the last op is an OP_REQUIRE, force scalar context.
2896      * Otherwise, propagate the context from the eval(). */
2897     if (PL_eval_root->op_type == OP_LEAVEEVAL
2898             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2899             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2900             == OP_REQUIRE)
2901         scalar(PL_eval_root);
2902     else if (gimme & G_VOID)
2903         scalarvoid(PL_eval_root);
2904     else if (gimme & G_ARRAY)
2905         list(PL_eval_root);
2906     else
2907         scalar(PL_eval_root);
2908
2909     DEBUG_x(dump_eval());
2910
2911     /* Register with debugger: */
2912     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2913         CV *cv = get_cv("DB::postponed", FALSE);
2914         if (cv) {
2915             dSP;
2916             PUSHMARK(SP);
2917             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2918             PUTBACK;
2919             call_sv((SV*)cv, G_DISCARD);
2920         }
2921     }
2922
2923     /* compiled okay, so do it */
2924
2925     CvDEPTH(PL_compcv) = 1;
2926     SP = PL_stack_base + POPMARK;               /* pop original mark */
2927     PL_op = saveop;                     /* The caller may need it. */
2928     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2929
2930     RETURNOP(PL_eval_start);
2931 }
2932
2933 STATIC PerlIO *
2934 S_doopen_pm(pTHX_ const char *name, const char *mode)
2935 {
2936 #ifndef PERL_DISABLE_PMC
2937     STRLEN namelen = strlen(name);
2938     PerlIO *fp;
2939
2940     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2941         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2942         char *pmc = SvPV_nolen(pmcsv);
2943         Stat_t pmstat;
2944         Stat_t pmcstat;
2945         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2946             fp = PerlIO_open(name, mode);
2947         }
2948         else {
2949             if (PerlLIO_stat(name, &pmstat) < 0 ||
2950                 pmstat.st_mtime < pmcstat.st_mtime)
2951             {
2952                 fp = PerlIO_open(pmc, mode);
2953             }
2954             else {
2955                 fp = PerlIO_open(name, mode);
2956             }
2957         }
2958         SvREFCNT_dec(pmcsv);
2959     }
2960     else {
2961         fp = PerlIO_open(name, mode);
2962     }
2963     return fp;
2964 #else
2965     return PerlIO_open(name, mode);
2966 #endif /* !PERL_DISABLE_PMC */
2967 }
2968
2969 PP(pp_require)
2970 {
2971     dSP;
2972     register PERL_CONTEXT *cx;
2973     SV *sv;
2974     char *name;
2975     STRLEN len;
2976     char *tryname = Nullch;
2977     SV *namesv = Nullsv;
2978     SV** svp;
2979     I32 gimme = GIMME_V;
2980     PerlIO *tryrsfp = 0;
2981     STRLEN n_a;
2982     int filter_has_file = 0;
2983     GV *filter_child_proc = 0;
2984     SV *filter_state = 0;
2985     SV *filter_sub = 0;
2986     SV *hook_sv = 0;
2987     SV *encoding;
2988     OP *op;
2989
2990     sv = POPs;
2991     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2992         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2993             UV rev = 0, ver = 0, sver = 0;
2994             STRLEN len;
2995             U8 *s = (U8*)SvPVX(sv);
2996             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2997             if (s < end) {
2998                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2999                 s += len;
3000                 if (s < end) {
3001                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
3002                     s += len;
3003                     if (s < end)
3004                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
3005                 }
3006             }
3007             if (PERL_REVISION < rev
3008                 || (PERL_REVISION == rev
3009                     && (PERL_VERSION < ver
3010                         || (PERL_VERSION == ver
3011                             && PERL_SUBVERSION < sver))))
3012             {
3013                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
3014                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
3015                     PERL_VERSION, PERL_SUBVERSION);
3016             }
3017             if (ckWARN(WARN_PORTABLE))
3018                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3019                         "v-string in use/require non-portable");
3020             RETPUSHYES;
3021         }
3022         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
3023             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
3024                 + ((NV)PERL_SUBVERSION/(NV)1000000)
3025                 + 0.00000099 < SvNV(sv))
3026             {
3027                 NV nrev = SvNV(sv);
3028                 UV rev = (UV)nrev;
3029                 NV nver = (nrev - rev) * 1000;
3030                 UV ver = (UV)(nver + 0.0009);
3031                 NV nsver = (nver - ver) * 1000;
3032                 UV sver = (UV)(nsver + 0.0009);
3033
3034                 /* help out with the "use 5.6" confusion */
3035                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
3036                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
3037                         " (did you mean v%"UVuf".%03"UVuf"?)--"
3038                         "this is only v%d.%d.%d, stopped",
3039                         rev, ver, sver, rev, ver/100,
3040                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
3041                 }
3042                 else {
3043                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
3044                         "this is only v%d.%d.%d, stopped",
3045                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
3046                         PERL_SUBVERSION);
3047                 }
3048             }
3049             RETPUSHYES;
3050         }
3051     }
3052     name = SvPV(sv, len);
3053     if (!(name && len > 0 && *name))
3054         DIE(aTHX_ "Null filename used");
3055     TAINT_PROPER("require");
3056     if (PL_op->op_type == OP_REQUIRE &&
3057        (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3058        if (*svp != &PL_sv_undef)
3059            RETPUSHYES;
3060        else
3061            DIE(aTHX_ "Compilation failed in require");
3062     }
3063
3064     /* prepare to compile file */
3065
3066     if (path_is_absolute(name)) {
3067         tryname = name;
3068         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3069     }
3070 #ifdef MACOS_TRADITIONAL
3071     if (!tryrsfp) {
3072         char newname[256];
3073
3074         MacPerl_CanonDir(name, newname, 1);
3075         if (path_is_absolute(newname)) {
3076             tryname = newname;
3077             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3078         }
3079     }
3080 #endif
3081     if (!tryrsfp) {
3082         AV *ar = GvAVn(PL_incgv);
3083         I32 i;
3084 #ifdef VMS
3085         char *unixname;
3086         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3087 #endif
3088         {
3089             namesv = NEWSV(806, 0);
3090             for (i = 0; i <= AvFILL(ar); i++) {
3091                 SV *dirsv = *av_fetch(ar, i, TRUE);
3092
3093                 if (SvROK(dirsv)) {
3094                     int count;
3095                     SV *loader = dirsv;
3096
3097                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3098                         && !sv_isobject(loader))
3099                     {
3100                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3101                     }
3102
3103                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3104                                    PTR2UV(SvRV(dirsv)), name);
3105                     tryname = SvPVX(namesv);
3106                     tryrsfp = 0;
3107
3108                     ENTER;
3109                     SAVETMPS;
3110                     EXTEND(SP, 2);
3111
3112                     PUSHMARK(SP);
3113                     PUSHs(dirsv);
3114                     PUSHs(sv);
3115                     PUTBACK;
3116                     if (sv_isobject(loader))
3117                         count = call_method("INC", G_ARRAY);
3118                     else
3119                         count = call_sv(loader, G_ARRAY);
3120                     SPAGAIN;
3121
3122                     if (count > 0) {
3123                         int i = 0;
3124                         SV *arg;
3125
3126                         SP -= count - 1;
3127                         arg = SP[i++];
3128
3129                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3130                             arg = SvRV(arg);
3131                         }
3132
3133                         if (SvTYPE(arg) == SVt_PVGV) {
3134                             IO *io = GvIO((GV *)arg);
3135
3136                             ++filter_has_file;
3137
3138                             if (io) {
3139                                 tryrsfp = IoIFP(io);
3140                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3141                                     /* reading from a child process doesn't
3142                                        nest -- when returning from reading
3143                                        the inner module, the outer one is
3144                                        unreadable (closed?)  I've tried to
3145                                        save the gv to manage the lifespan of
3146                                        the pipe, but this didn't help. XXX */
3147                                     filter_child_proc = (GV *)arg;
3148                                     (void)SvREFCNT_inc(filter_child_proc);
3149                                 }
3150                                 else {
3151                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3152                                         PerlIO_close(IoOFP(io));
3153                                     }
3154                                     IoIFP(io) = Nullfp;
3155                                     IoOFP(io) = Nullfp;
3156                                 }
3157                             }
3158
3159                             if (i < count) {
3160                                 arg = SP[i++];
3161                             }
3162                         }
3163
3164                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3165                             filter_sub = arg;
3166                             (void)SvREFCNT_inc(filter_sub);
3167
3168                             if (i < count) {
3169                                 filter_state = SP[i];
3170                                 (void)SvREFCNT_inc(filter_state);
3171                             }
3172
3173                             if (tryrsfp == 0) {
3174                                 tryrsfp = PerlIO_open("/dev/null",
3175                                                       PERL_SCRIPT_MODE);
3176                             }
3177                         }
3178                         SP--;
3179                     }
3180
3181                     PUTBACK;
3182                     FREETMPS;
3183                     LEAVE;
3184
3185                     if (tryrsfp) {
3186                         hook_sv = dirsv;
3187                         break;
3188                     }
3189
3190                     filter_has_file = 0;
3191                     if (filter_child_proc) {
3192                         SvREFCNT_dec(filter_child_proc);
3193                         filter_child_proc = 0;
3194                     }
3195                     if (filter_state) {
3196                         SvREFCNT_dec(filter_state);
3197                         filter_state = 0;
3198                     }
3199                     if (filter_sub) {
3200                         SvREFCNT_dec(filter_sub);
3201                         filter_sub = 0;
3202                     }
3203                 }
3204                 else {
3205                   if (!path_is_absolute(name)
3206 #ifdef MACOS_TRADITIONAL
3207                         /* We consider paths of the form :a:b ambiguous and interpret them first
3208                            as global then as local
3209                         */
3210                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3211 #endif
3212                   ) {
3213                     char *dir = SvPVx(dirsv, n_a);
3214 #ifdef MACOS_TRADITIONAL
3215                     char buf1[256];
3216                     char buf2[256];
3217
3218                     MacPerl_CanonDir(name, buf2, 1);
3219                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3220 #else
3221 #ifdef VMS
3222                     char *unixdir;
3223                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3224                         continue;
3225                     sv_setpv(namesv, unixdir);
3226                     sv_catpv(namesv, unixname);
3227 #else
3228                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3229 #endif
3230 #endif
3231                     TAINT_PROPER("require");
3232                     tryname = SvPVX(namesv);
3233                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3234                     if (tryrsfp) {
3235                         if (tryname[0] == '.' && tryname[1] == '/')
3236                             tryname += 2;
3237                         break;
3238                     }
3239                   }
3240                 }
3241             }
3242         }
3243     }
3244     SAVECOPFILE_FREE(&PL_compiling);
3245     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3246     SvREFCNT_dec(namesv);
3247     if (!tryrsfp) {
3248         if (PL_op->op_type == OP_REQUIRE) {
3249             char *msgstr = name;
3250             if (namesv) {                       /* did we lookup @INC? */
3251                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3252                 SV *dirmsgsv = NEWSV(0, 0);
3253                 AV *ar = GvAVn(PL_incgv);
3254                 I32 i;
3255                 sv_catpvn(msg, " in @INC", 8);
3256                 if (instr(SvPVX(msg), ".h "))
3257                     sv_catpv(msg, " (change .h to .ph maybe?)");
3258                 if (instr(SvPVX(msg), ".ph "))
3259                     sv_catpv(msg, " (did you run h2ph?)");
3260                 sv_catpv(msg, " (@INC contains:");
3261                 for (i = 0; i <= AvFILL(ar); i++) {
3262                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3263                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3264                     sv_catsv(msg, dirmsgsv);
3265                 }
3266                 sv_catpvn(msg, ")", 1);
3267                 SvREFCNT_dec(dirmsgsv);
3268                 msgstr = SvPV_nolen(msg);
3269             }
3270             DIE(aTHX_ "Can't locate %s", msgstr);
3271         }
3272
3273         RETPUSHUNDEF;
3274     }
3275     else
3276         SETERRNO(0, SS_NORMAL);
3277
3278     /* Assume success here to prevent recursive requirement. */
3279     len = strlen(name);
3280     /* Check whether a hook in @INC has already filled %INC */
3281     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3282         (void)hv_store(GvHVn(PL_incgv), name, len,
3283                        (hook_sv ? SvREFCNT_inc(hook_sv)
3284                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3285                        0 );
3286     }
3287
3288     ENTER;
3289     SAVETMPS;
3290     lex_start(sv_2mortal(newSVpvn("",0)));
3291     SAVEGENERICSV(PL_rsfp_filters);
3292     PL_rsfp_filters = Nullav;
3293
3294     PL_rsfp = tryrsfp;
3295     SAVEHINTS();
3296     PL_hints = 0;
3297     SAVESPTR(PL_compiling.cop_warnings);
3298     if (PL_dowarn & G_WARN_ALL_ON)
3299         PL_compiling.cop_warnings = pWARN_ALL ;
3300     else if (PL_dowarn & G_WARN_ALL_OFF)
3301         PL_compiling.cop_warnings = pWARN_NONE ;
3302     else if (PL_taint_warn)
3303         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3304     else
3305         PL_compiling.cop_warnings = pWARN_STD ;
3306     SAVESPTR(PL_compiling.cop_io);
3307     PL_compiling.cop_io = Nullsv;
3308
3309     if (filter_sub || filter_child_proc) {
3310         SV *datasv = filter_add(run_user_filter, Nullsv);
3311         IoLINES(datasv) = filter_has_file;
3312         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3313         IoTOP_GV(datasv) = (GV *)filter_state;
3314         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3315     }
3316
3317     /* switch to eval mode */
3318     push_return(PL_op->op_next);
3319     PUSHBLOCK(cx, CXt_EVAL, SP);
3320     PUSHEVAL(cx, name, Nullgv);
3321
3322     SAVECOPLINE(&PL_compiling);
3323     CopLINE_set(&PL_compiling, 0);
3324
3325     PUTBACK;
3326
3327     /* Store and reset encoding. */
3328     encoding = PL_encoding;
3329     PL_encoding = Nullsv;
3330
3331     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3332
3333     /* Restore encoding. */
3334     PL_encoding = encoding;
3335
3336     return op;
3337 }
3338
3339 PP(pp_dofile)
3340 {
3341     return pp_require();
3342 }
3343
3344 PP(pp_entereval)
3345 {
3346     dSP;
3347     register PERL_CONTEXT *cx;
3348     dPOPss;
3349     I32 gimme = GIMME_V, was = PL_sub_generation;
3350     char tbuf[TYPE_DIGITS(long) + 12];
3351     char *tmpbuf = tbuf;
3352     char *safestr;
3353     STRLEN len;
3354     OP *ret;
3355     CV* runcv;
3356     U32 seq;
3357
3358     if (!SvPV(sv,len))
3359         RETPUSHUNDEF;
3360     TAINT_PROPER("eval");
3361
3362     ENTER;
3363     lex_start(sv);
3364     SAVETMPS;
3365
3366     /* switch to eval mode */
3367
3368     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3369         SV *sv = sv_newmortal();
3370         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3371                        (unsigned long)++PL_evalseq,
3372                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3373         tmpbuf = SvPVX(sv);
3374     }
3375     else
3376         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3377     SAVECOPFILE_FREE(&PL_compiling);
3378     CopFILE_set(&PL_compiling, tmpbuf+2);
3379     SAVECOPLINE(&PL_compiling);
3380     CopLINE_set(&PL_compiling, 1);
3381     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3382        deleting the eval's FILEGV from the stash before gv_check() runs
3383        (i.e. before run-time proper). To work around the coredump that
3384        ensues, we always turn GvMULTI_on for any globals that were
3385        introduced within evals. See force_ident(). GSAR 96-10-12 */
3386     safestr = savepv(tmpbuf);
3387     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3388     SAVEHINTS();
3389     PL_hints = PL_op->op_targ;
3390     SAVESPTR(PL_compiling.cop_warnings);
3391     if (specialWARN(PL_curcop->cop_warnings))
3392         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3393     else {
3394         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3395         SAVEFREESV(PL_compiling.cop_warnings);
3396     }
3397     SAVESPTR(PL_compiling.cop_io);
3398     if (specialCopIO(PL_curcop->cop_io))
3399         PL_compiling.cop_io = PL_curcop->cop_io;
3400     else {
3401         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3402         SAVEFREESV(PL_compiling.cop_io);
3403     }
3404     /* special case: an eval '' executed within the DB package gets lexically
3405      * placed in the first non-DB CV rather than the current CV - this
3406      * allows the debugger to execute code, find lexicals etc, in the
3407      * scope of the code being debugged. Passing &seq gets find_runcv
3408      * to do the dirty work for us */
3409     runcv = find_runcv(&seq);
3410
3411     push_return(PL_op->op_next);
3412     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3413     PUSHEVAL(cx, 0, Nullgv);
3414
3415     /* prepare to compile string */
3416
3417     if (PERLDB_LINE && PL_curstash != PL_debstash)
3418         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3419     PUTBACK;
3420     ret = doeval(gimme, NULL, runcv, seq);
3421     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3422         && ret != PL_op->op_next) {     /* Successive compilation. */
3423         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3424     }
3425     return DOCATCH(ret);
3426 }
3427
3428 PP(pp_leaveeval)
3429 {
3430     dSP;
3431     register SV **mark;
3432     SV **newsp;
3433     PMOP *newpm;
3434     I32 gimme;
3435     register PERL_CONTEXT *cx;
3436     OP *retop;
3437     U8 save_flags = PL_op -> op_flags;
3438     I32 optype;
3439
3440     POPBLOCK(cx,newpm);
3441     POPEVAL(cx);
3442     retop = pop_return();
3443
3444     TAINT_NOT;
3445     if (gimme == G_VOID)
3446         MARK = newsp;
3447     else if (gimme == G_SCALAR) {
3448         MARK = newsp + 1;
3449         if (MARK <= SP) {
3450             if (SvFLAGS(TOPs) & SVs_TEMP)
3451                 *MARK = TOPs;
3452             else
3453                 *MARK = sv_mortalcopy(TOPs);
3454         }
3455         else {
3456             MEXTEND(mark,0);
3457             *MARK = &PL_sv_undef;
3458         }
3459         SP = MARK;
3460     }
3461     else {
3462         /* in case LEAVE wipes old return values */
3463         for (mark = newsp + 1; mark <= SP; mark++) {
3464             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3465                 *mark = sv_mortalcopy(*mark);
3466                 TAINT_NOT;      /* Each item is independent */
3467             }
3468         }
3469     }
3470     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3471
3472 #ifdef DEBUGGING
3473     assert(CvDEPTH(PL_compcv) == 1);
3474 #endif
3475     CvDEPTH(PL_compcv) = 0;
3476     lex_end();
3477
3478     if (optype == OP_REQUIRE &&
3479         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3480     {
3481         /* Unassume the success we assumed earlier. */
3482         SV *nsv = cx->blk_eval.old_namesv;
3483         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3484         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3485         /* die_where() did LEAVE, or we won't be here */
3486     }
3487     else {
3488         LEAVE;
3489         if (!(save_flags & OPf_SPECIAL))
3490             sv_setpv(ERRSV,"");
3491     }
3492
3493     RETURNOP(retop);
3494 }
3495
3496 PP(pp_entertry)
3497 {
3498     dSP;
3499     register PERL_CONTEXT *cx;
3500     I32 gimme = GIMME_V;
3501
3502     ENTER;
3503     SAVETMPS;
3504
3505     push_return(cLOGOP->op_other->op_next);
3506     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3507     PUSHEVAL(cx, 0, 0);
3508
3509     PL_in_eval = EVAL_INEVAL;
3510     sv_setpv(ERRSV,"");
3511     PUTBACK;
3512     return DOCATCH(PL_op->op_next);
3513 }
3514
3515 PP(pp_leavetry)
3516 {
3517     dSP;
3518     register SV **mark;
3519     SV **newsp;
3520     PMOP *newpm;
3521     OP* retop;
3522     I32 gimme;
3523     register PERL_CONTEXT *cx;
3524     I32 optype;
3525
3526     POPBLOCK(cx,newpm);
3527     POPEVAL(cx);
3528     retop = pop_return();
3529
3530     TAINT_NOT;
3531     if (gimme == G_VOID)
3532         SP = newsp;
3533     else if (gimme == G_SCALAR) {
3534         MARK = newsp + 1;
3535         if (MARK <= SP) {
3536             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3537                 *MARK = TOPs;
3538             else
3539                 *MARK = sv_mortalcopy(TOPs);
3540         }
3541         else {
3542             MEXTEND(mark,0);
3543             *MARK = &PL_sv_undef;
3544         }
3545         SP = MARK;
3546     }
3547     else {
3548         /* in case LEAVE wipes old return values */
3549         for (mark = newsp + 1; mark <= SP; mark++) {
3550             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3551                 *mark = sv_mortalcopy(*mark);
3552                 TAINT_NOT;      /* Each item is independent */
3553             }
3554         }
3555     }
3556     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3557
3558     LEAVE;
3559     sv_setpv(ERRSV,"");
3560     RETURNOP(retop);
3561 }
3562
3563 STATIC void
3564 S_doparseform(pTHX_ SV *sv)
3565 {
3566     STRLEN len;
3567     register char *s = SvPV_force(sv, len);
3568     register char *send = s + len;
3569     register char *base = Nullch;
3570     register I32 skipspaces = 0;
3571     bool noblank   = FALSE;
3572     bool repeat    = FALSE;
3573     bool postspace = FALSE;
3574     U32 *fops;
3575     register U32 *fpc;
3576     U32 *linepc = 0;
3577     register I32 arg;
3578     bool ischop;
3579     int maxops = 2; /* FF_LINEMARK + FF_END) */
3580
3581     if (len == 0)
3582         Perl_croak(aTHX_ "Null picture in formline");
3583
3584     /* estimate the buffer size needed */
3585     for (base = s; s <= send; s++) {
3586         if (*s == '\n' || *s == '@' || *s == '^')
3587             maxops += 10;
3588     }
3589     s = base;
3590     base = Nullch;
3591
3592     New(804, fops, maxops, U32);
3593     fpc = fops;
3594
3595     if (s < send) {
3596         linepc = fpc;
3597         *fpc++ = FF_LINEMARK;
3598         noblank = repeat = FALSE;
3599         base = s;
3600     }
3601
3602     while (s <= send) {
3603         switch (*s++) {
3604         default:
3605             skipspaces = 0;
3606             continue;
3607
3608         case '~':
3609             if (*s == '~') {
3610                 repeat = TRUE;
3611                 *s = ' ';
3612             }
3613             noblank = TRUE;
3614             s[-1] = ' ';
3615             /* FALL THROUGH */
3616         case ' ': case '\t':
3617             skipspaces++;
3618             continue;
3619
3620         case '\n': case 0:
3621             arg = s - base;
3622             skipspaces++;
3623             arg -= skipspaces;
3624             if (arg) {
3625                 if (postspace)
3626                     *fpc++ = FF_SPACE;
3627                 *fpc++ = FF_LITERAL;
3628                 *fpc++ = (U16)arg;
3629             }
3630             postspace = FALSE;
3631             if (s <= send)
3632                 skipspaces--;
3633             if (skipspaces) {
3634                 *fpc++ = FF_SKIP;
3635                 *fpc++ = (U16)skipspaces;
3636             }
3637             skipspaces = 0;
3638             if (s <= send)
3639                 *fpc++ = FF_NEWLINE;
3640             if (noblank) {
3641                 *fpc++ = FF_BLANK;
3642                 if (repeat)
3643                     arg = fpc - linepc + 1;
3644                 else
3645                     arg = 0;
3646                 *fpc++ = (U16)arg;
3647             }
3648             if (s < send) {
3649                 linepc = fpc;
3650                 *fpc++ = FF_LINEMARK;
3651                 noblank = repeat = FALSE;
3652                 base = s;
3653             }
3654             else
3655                 s++;
3656             continue;
3657
3658         case '@':
3659         case '^':
3660             ischop = s[-1] == '^';
3661
3662             if (postspace) {
3663                 *fpc++ = FF_SPACE;
3664                 postspace = FALSE;
3665             }
3666             arg = (s - base) - 1;
3667             if (arg) {
3668                 *fpc++ = FF_LITERAL;
3669                 *fpc++ = (U16)arg;
3670             }
3671
3672             base = s - 1;
3673             *fpc++ = FF_FETCH;
3674             if (*s == '*') {
3675                 s++;
3676                 *fpc++ = 0;
3677                 *fpc++ = FF_LINEGLOB;
3678             }
3679             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3680                 arg = ischop ? 512 : 0;
3681                 base = s - 1;
3682                 while (*s == '#')
3683                     s++;
3684                 if (*s == '.') {
3685                     char *f;
3686                     s++;
3687                     f = s;
3688                     while (*s == '#')
3689                         s++;
3690                     arg |= 256 + (s - f);
3691                 }
3692                 *fpc++ = s - base;              /* fieldsize for FETCH */
3693                 *fpc++ = FF_DECIMAL;
3694                 *fpc++ = (U16)arg;
3695             }
3696             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3697                 arg = ischop ? 512 : 0;
3698                 base = s - 1;
3699                 s++;                                /* skip the '0' first */
3700                 while (*s == '#')
3701                     s++;
3702                 if (*s == '.') {
3703                     char *f;
3704                     s++;
3705                     f = s;
3706                     while (*s == '#')
3707                         s++;
3708                     arg |= 256 + (s - f);
3709                 }
3710                 *fpc++ = s - base;                /* fieldsize for FETCH */
3711                 *fpc++ = FF_0DECIMAL;
3712                 *fpc++ = (U16)arg;
3713             }
3714             else {
3715                 I32 prespace = 0;
3716                 bool ismore = FALSE;
3717
3718                 if (*s == '>') {
3719                     while (*++s == '>') ;
3720                     prespace = FF_SPACE;
3721                 }
3722                 else if (*s == '|') {
3723                     while (*++s == '|') ;
3724                     prespace = FF_HALFSPACE;
3725                     postspace = TRUE;
3726                 }
3727                 else {
3728                     if (*s == '<')
3729                         while (*++s == '<') ;
3730                     postspace = TRUE;
3731                 }
3732                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3733                     s += 3;
3734                     ismore = TRUE;
3735                 }
3736                 *fpc++ = s - base;              /* fieldsize for FETCH */
3737
3738                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3739
3740                 if (prespace)
3741                     *fpc++ = (U16)prespace;
3742                 *fpc++ = FF_ITEM;
3743                 if (ismore)
3744                     *fpc++ = FF_MORE;
3745                 if (ischop)
3746                     *fpc++ = FF_CHOP;
3747             }
3748             base = s;
3749             skipspaces = 0;
3750             continue;
3751         }
3752     }
3753     *fpc++ = FF_END;
3754
3755     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3756     arg = fpc - fops;
3757     { /* need to jump to the next word */
3758         int z;
3759         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3760         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3761         s = SvPVX(sv) + SvCUR(sv) + z;
3762     }
3763     Copy(fops, s, arg, U32);
3764     Safefree(fops);
3765     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3766     SvCOMPILED_on(sv);
3767 }
3768
3769 static I32
3770 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3771 {
3772     SV *datasv = FILTER_DATA(idx);
3773     int filter_has_file = IoLINES(datasv);
3774     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3775     SV *filter_state = (SV *)IoTOP_GV(datasv);
3776     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3777     int len = 0;
3778
3779     /* I was having segfault trouble under Linux 2.2.5 after a
3780        parse error occured.  (Had to hack around it with a test
3781        for PL_error_count == 0.)  Solaris doesn't segfault --
3782        not sure where the trouble is yet.  XXX */
3783
3784     if (filter_has_file) {
3785         len = FILTER_READ(idx+1, buf_sv, maxlen);
3786     }
3787
3788     if (filter_sub && len >= 0) {
3789         dSP;
3790         int count;
3791
3792         ENTER;
3793         SAVE_DEFSV;
3794         SAVETMPS;
3795         EXTEND(SP, 2);
3796
3797         DEFSV = buf_sv;
3798         PUSHMARK(SP);
3799         PUSHs(sv_2mortal(newSViv(maxlen)));
3800         if (filter_state) {
3801             PUSHs(filter_state);
3802         }
3803         PUTBACK;
3804         count = call_sv(filter_sub, G_SCALAR);
3805         SPAGAIN;
3806
3807         if (count > 0) {
3808             SV *out = POPs;
3809             if (SvOK(out)) {
3810                 len = SvIV(out);
3811             }
3812         }
3813
3814         PUTBACK;
3815         FREETMPS;
3816         LEAVE;
3817     }
3818
3819     if (len <= 0) {
3820         IoLINES(datasv) = 0;
3821         if (filter_child_proc) {
3822             SvREFCNT_dec(filter_child_proc);
3823             IoFMT_GV(datasv) = Nullgv;
3824         }
3825         if (filter_state) {
3826             SvREFCNT_dec(filter_state);
3827             IoTOP_GV(datasv) = Nullgv;
3828         }
3829         if (filter_sub) {
3830             SvREFCNT_dec(filter_sub);
3831             IoBOTTOM_GV(datasv) = Nullgv;
3832         }
3833         filter_del(run_user_filter);
3834     }
3835
3836     return len;
3837 }
3838
3839 /* perhaps someone can come up with a better name for
3840    this?  it is not really "absolute", per se ... */
3841 static bool
3842 S_path_is_absolute(pTHX_ char *name)
3843 {
3844     if (PERL_FILE_IS_ABSOLUTE(name)
3845 #ifdef MACOS_TRADITIONAL
3846         || (*name == ':'))
3847 #else
3848         || (*name == '.' && (name[1] == '/' ||
3849                              (name[1] == '.' && name[2] == '/'))))
3850 #endif
3851     {
3852         return TRUE;
3853     }
3854     else
3855         return FALSE;
3856 }