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