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