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