pp_ctl.c

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