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