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