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     PL_reg_match_utf8 = SvUTF8(cx->sb_targ) ? 1 : 0;
 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_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1587     {
1588         dSP;
1589         register CV *cv;
1590         register PERL_CONTEXT *cx;
1591         I32 gimme = G_ARRAY;
1592         U8 hasargs;
1593         GV *gv;
1594
1595         gv = PL_DBgv;
1596         cv = GvCV(gv);
1597         if (!cv)
1598             DIE(aTHX_ "No DB::DB routine defined");
1599
1600         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1601             /* don't do recursive DB::DB call */
1602             return NORMAL;
1603
1604         ENTER;
1605         SAVETMPS;
1606
1607         SAVEI32(PL_debug);
1608         SAVESTACK_POS();
1609         PL_debug = 0;
1610         hasargs = 0;
1611         SPAGAIN;
1612
1613         push_return(PL_op->op_next);
1614         PUSHBLOCK(cx, CXt_SUB, SP);
1615         PUSHSUB(cx);
1616         CvDEPTH(cv)++;
1617         (void)SvREFCNT_inc(cv);
1618         PAD_SET_CUR(CvPADLIST(cv),1);
1619         RETURNOP(CvSTART(cv));
1620     }
1621     else
1622         return NORMAL;
1623 }
1624
1625 PP(pp_scope)
1626 {
1627     return NORMAL;
1628 }
1629
1630 PP(pp_enteriter)
1631 {
1632     dSP; dMARK;
1633     register PERL_CONTEXT *cx;
1634     I32 gimme = GIMME_V;
1635     SV **svp;
1636     U32 cxtype = CXt_LOOP;
1637 #ifdef USE_ITHREADS
1638     void *iterdata;
1639 #endif
1640
1641     ENTER;
1642     SAVETMPS;
1643
1644     if (PL_op->op_targ) {
1645 #ifndef USE_ITHREADS
1646         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1647         SAVESPTR(*svp);
1648 #else
1649         SAVEPADSV(PL_op->op_targ);
1650         iterdata = INT2PTR(void*, PL_op->op_targ);
1651         cxtype |= CXp_PADVAR;
1652 #endif
1653     }
1654     else {
1655         GV *gv = (GV*)POPs;
1656         svp = &GvSV(gv);                        /* symbol table variable */
1657         SAVEGENERICSV(*svp);
1658         *svp = NEWSV(0,0);
1659 #ifdef USE_ITHREADS
1660         iterdata = (void*)gv;
1661 #endif
1662     }
1663
1664     ENTER;
1665
1666     PUSHBLOCK(cx, cxtype, SP);
1667 #ifdef USE_ITHREADS
1668     PUSHLOOP(cx, iterdata, MARK);
1669 #else
1670     PUSHLOOP(cx, svp, MARK);
1671 #endif
1672     if (PL_op->op_flags & OPf_STACKED) {
1673         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1674         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1675             dPOPss;
1676             /* See comment in pp_flop() */
1677             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1678                 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1679                 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1680                  looks_like_number((SV*)cx->blk_loop.iterary)))
1681             {
1682                  if (SvNV(sv) < IV_MIN ||
1683                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1684                      DIE(aTHX_ "Range iterator outside integer range");
1685                  cx->blk_loop.iterix = SvIV(sv);
1686                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1687             }
1688             else
1689                 cx->blk_loop.iterlval = newSVsv(sv);
1690         }
1691     }
1692     else {
1693         cx->blk_loop.iterary = PL_curstack;
1694         AvFILLp(PL_curstack) = SP - PL_stack_base;
1695         cx->blk_loop.iterix = MARK - PL_stack_base;
1696     }
1697
1698     RETURN;
1699 }
1700
1701 PP(pp_enterloop)
1702 {
1703     dSP;
1704     register PERL_CONTEXT *cx;
1705     I32 gimme = GIMME_V;
1706
1707     ENTER;
1708     SAVETMPS;
1709     ENTER;
1710
1711     PUSHBLOCK(cx, CXt_LOOP, SP);
1712     PUSHLOOP(cx, 0, SP);
1713
1714     RETURN;
1715 }
1716
1717 PP(pp_leaveloop)
1718 {
1719     dSP;
1720     register PERL_CONTEXT *cx;
1721     I32 gimme;
1722     SV **newsp;
1723     PMOP *newpm;
1724     SV **mark;
1725
1726     POPBLOCK(cx,newpm);
1727     mark = newsp;
1728     newsp = PL_stack_base + cx->blk_loop.resetsp;
1729
1730     TAINT_NOT;
1731     if (gimme == G_VOID)
1732         ; /* do nothing */
1733     else if (gimme == G_SCALAR) {
1734         if (mark < SP)
1735             *++newsp = sv_mortalcopy(*SP);
1736         else
1737             *++newsp = &PL_sv_undef;
1738     }
1739     else {
1740         while (mark < SP) {
1741             *++newsp = sv_mortalcopy(*++mark);
1742             TAINT_NOT;          /* Each item is independent */
1743         }
1744     }
1745     SP = newsp;
1746     PUTBACK;
1747
1748     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1749     PL_curpm = newpm;   /* ... and pop $1 et al */
1750
1751     LEAVE;
1752     LEAVE;
1753
1754     return NORMAL;
1755 }
1756
1757 PP(pp_return)
1758 {
1759     dSP; dMARK;
1760     I32 cxix;
1761     register PERL_CONTEXT *cx;
1762     bool popsub2 = FALSE;
1763     bool clear_errsv = FALSE;
1764     I32 gimme;
1765     SV **newsp;
1766     PMOP *newpm;
1767     I32 optype = 0;
1768     SV *sv;
1769
1770     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1771         if (cxstack_ix == PL_sortcxix
1772             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1773         {
1774             if (cxstack_ix > PL_sortcxix)
1775                 dounwind(PL_sortcxix);
1776             AvARRAY(PL_curstack)[1] = *SP;
1777             PL_stack_sp = PL_stack_base + 1;
1778             return 0;
1779         }
1780     }
1781
1782     cxix = dopoptosub(cxstack_ix);
1783     if (cxix < 0)
1784         DIE(aTHX_ "Can't return outside a subroutine");
1785     if (cxix < cxstack_ix)
1786         dounwind(cxix);
1787
1788     POPBLOCK(cx,newpm);
1789     switch (CxTYPE(cx)) {
1790     case CXt_SUB:
1791         popsub2 = TRUE;
1792         break;
1793     case CXt_EVAL:
1794         if (!(PL_in_eval & EVAL_KEEPERR))
1795             clear_errsv = TRUE;
1796         POPEVAL(cx);
1797         if (CxTRYBLOCK(cx))
1798             break;
1799         lex_end();
1800         if (optype == OP_REQUIRE &&
1801             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1802         {
1803             /* Unassume the success we assumed earlier. */
1804             SV *nsv = cx->blk_eval.old_namesv;
1805             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1806             DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1807         }
1808         break;
1809     case CXt_FORMAT:
1810         POPFORMAT(cx);
1811         break;
1812     default:
1813         DIE(aTHX_ "panic: return");
1814     }
1815
1816     TAINT_NOT;
1817     if (gimme == G_SCALAR) {
1818         if (MARK < SP) {
1819             if (popsub2) {
1820                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1821                     if (SvTEMP(TOPs)) {
1822                         *++newsp = SvREFCNT_inc(*SP);
1823                         FREETMPS;
1824                         sv_2mortal(*newsp);
1825                     }
1826                     else {
1827                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1828                         FREETMPS;
1829                         *++newsp = sv_mortalcopy(sv);
1830                         SvREFCNT_dec(sv);
1831                     }
1832                 }
1833                 else
1834                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1835             }
1836             else
1837                 *++newsp = sv_mortalcopy(*SP);
1838         }
1839         else
1840             *++newsp = &PL_sv_undef;
1841     }
1842     else if (gimme == G_ARRAY) {
1843         while (++MARK <= SP) {
1844             *++newsp = (popsub2 && SvTEMP(*MARK))
1845                         ? *MARK : sv_mortalcopy(*MARK);
1846             TAINT_NOT;          /* Each item is independent */
1847         }
1848     }
1849     PL_stack_sp = newsp;
1850
1851     /* Stack values are safe: */
1852     if (popsub2) {
1853         POPSUB(cx,sv);  /* release CV and @_ ... */
1854     }
1855     else
1856         sv = Nullsv;
1857     PL_curpm = newpm;   /* ... and pop $1 et al */
1858
1859     LEAVE;
1860     LEAVESUB(sv);
1861     if (clear_errsv)
1862         sv_setpv(ERRSV,"");
1863     return pop_return();
1864 }
1865
1866 PP(pp_last)
1867 {
1868     dSP;
1869     I32 cxix;
1870     register PERL_CONTEXT *cx;
1871     I32 pop2 = 0;
1872     I32 gimme;
1873     I32 optype;
1874     OP *nextop;
1875     SV **newsp;
1876     PMOP *newpm;
1877     SV **mark;
1878     SV *sv = Nullsv;
1879
1880     if (PL_op->op_flags & OPf_SPECIAL) {
1881         cxix = dopoptoloop(cxstack_ix);
1882         if (cxix < 0)
1883             DIE(aTHX_ "Can't \"last\" outside a loop block");
1884     }
1885     else {
1886         cxix = dopoptolabel(cPVOP->op_pv);
1887         if (cxix < 0)
1888             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1889     }
1890     if (cxix < cxstack_ix)
1891         dounwind(cxix);
1892
1893     POPBLOCK(cx,newpm);
1894     mark = newsp;
1895     switch (CxTYPE(cx)) {
1896     case CXt_LOOP:
1897         pop2 = CXt_LOOP;
1898         newsp = PL_stack_base + cx->blk_loop.resetsp;
1899         nextop = cx->blk_loop.last_op->op_next;
1900         break;
1901     case CXt_SUB:
1902         pop2 = CXt_SUB;
1903         nextop = pop_return();
1904         break;
1905     case CXt_EVAL:
1906         POPEVAL(cx);
1907         nextop = pop_return();
1908         break;
1909     case CXt_FORMAT:
1910         POPFORMAT(cx);
1911         nextop = pop_return();
1912         break;
1913     default:
1914         DIE(aTHX_ "panic: last");
1915     }
1916
1917     TAINT_NOT;
1918     if (gimme == G_SCALAR) {
1919         if (MARK < SP)
1920             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1921                         ? *SP : sv_mortalcopy(*SP);
1922         else
1923             *++newsp = &PL_sv_undef;
1924     }
1925     else if (gimme == G_ARRAY) {
1926         while (++MARK <= SP) {
1927             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1928                         ? *MARK : sv_mortalcopy(*MARK);
1929             TAINT_NOT;          /* Each item is independent */
1930         }
1931     }
1932     SP = newsp;
1933     PUTBACK;
1934
1935     /* Stack values are safe: */
1936     switch (pop2) {
1937     case CXt_LOOP:
1938         POPLOOP(cx);    /* release loop vars ... */
1939         LEAVE;
1940         break;
1941     case CXt_SUB:
1942         POPSUB(cx,sv);  /* release CV and @_ ... */
1943         break;
1944     }
1945     PL_curpm = newpm;   /* ... and pop $1 et al */
1946
1947     LEAVE;
1948     LEAVESUB(sv);
1949     return nextop;
1950 }
1951
1952 PP(pp_next)
1953 {
1954     I32 cxix;
1955     register PERL_CONTEXT *cx;
1956     I32 inner;
1957
1958     if (PL_op->op_flags & OPf_SPECIAL) {
1959         cxix = dopoptoloop(cxstack_ix);
1960         if (cxix < 0)
1961             DIE(aTHX_ "Can't \"next\" outside a loop block");
1962     }
1963     else {
1964         cxix = dopoptolabel(cPVOP->op_pv);
1965         if (cxix < 0)
1966             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1967     }
1968     if (cxix < cxstack_ix)
1969         dounwind(cxix);
1970
1971     /* clear off anything above the scope we're re-entering, but
1972      * save the rest until after a possible continue block */
1973     inner = PL_scopestack_ix;
1974     TOPBLOCK(cx);
1975     if (PL_scopestack_ix < inner)
1976         leave_scope(PL_scopestack[PL_scopestack_ix]);
1977     return cx->blk_loop.next_op;
1978 }
1979
1980 PP(pp_redo)
1981 {
1982     I32 cxix;
1983     register PERL_CONTEXT *cx;
1984     I32 oldsave;
1985
1986     if (PL_op->op_flags & OPf_SPECIAL) {
1987         cxix = dopoptoloop(cxstack_ix);
1988         if (cxix < 0)
1989             DIE(aTHX_ "Can't \"redo\" outside a loop block");
1990     }
1991     else {
1992         cxix = dopoptolabel(cPVOP->op_pv);
1993         if (cxix < 0)
1994             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
1995     }
1996     if (cxix < cxstack_ix)
1997         dounwind(cxix);
1998
1999     TOPBLOCK(cx);
2000     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2001     LEAVE_SCOPE(oldsave);
2002     return cx->blk_loop.redo_op;
2003 }
2004
2005 STATIC OP *
2006 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2007 {
2008     OP *kid = Nullop;
2009     OP **ops = opstack;
2010     static char too_deep[] = "Target of goto is too deeply nested";
2011
2012     if (ops >= oplimit)
2013         Perl_croak(aTHX_ too_deep);
2014     if (o->op_type == OP_LEAVE ||
2015         o->op_type == OP_SCOPE ||
2016         o->op_type == OP_LEAVELOOP ||
2017         o->op_type == OP_LEAVETRY)
2018     {
2019         *ops++ = cUNOPo->op_first;
2020         if (ops >= oplimit)
2021             Perl_croak(aTHX_ too_deep);
2022     }
2023     *ops = 0;
2024     if (o->op_flags & OPf_KIDS) {
2025         /* First try all the kids at this level, since that's likeliest. */
2026         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2027             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2028                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2029                 return kid;
2030         }
2031         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2032             if (kid == PL_lastgotoprobe)
2033                 continue;
2034             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2035                 if (ops == opstack)
2036                     *ops++ = kid;
2037                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2038                          ops[-1]->op_type == OP_DBSTATE)
2039                     ops[-1] = kid;
2040                 else
2041                     *ops++ = kid;
2042             }
2043             if ((o = dofindlabel(kid, label, ops, oplimit)))
2044                 return o;
2045         }
2046     }
2047     *ops = 0;
2048     return 0;
2049 }
2050
2051 PP(pp_dump)
2052 {
2053     return pp_goto();
2054     /*NOTREACHED*/
2055 }
2056
2057 PP(pp_goto)
2058 {
2059     dSP;
2060     OP *retop = 0;
2061     I32 ix;
2062     register PERL_CONTEXT *cx;
2063 #define GOTO_DEPTH 64
2064     OP *enterops[GOTO_DEPTH];
2065     char *label;
2066     int do_dump = (PL_op->op_type == OP_DUMP);
2067     static char must_have_label[] = "goto must have label";
2068
2069     label = 0;
2070     if (PL_op->op_flags & OPf_STACKED) {
2071         SV *sv = POPs;
2072         STRLEN n_a;
2073
2074         /* This egregious kludge implements goto &subroutine */
2075         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2076             I32 cxix;
2077             register PERL_CONTEXT *cx;
2078             CV* cv = (CV*)SvRV(sv);
2079             SV** mark;
2080             I32 items = 0;
2081             I32 oldsave;
2082
2083         retry:
2084             if (!CvROOT(cv) && !CvXSUB(cv)) {
2085                 GV *gv = CvGV(cv);
2086                 GV *autogv;
2087                 if (gv) {
2088                     SV *tmpstr;
2089                     /* autoloaded stub? */
2090                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2091                         goto retry;
2092                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2093                                           GvNAMELEN(gv), FALSE);
2094                     if (autogv && (cv = GvCV(autogv)))
2095                         goto retry;
2096                     tmpstr = sv_newmortal();
2097                     gv_efullname3(tmpstr, gv, Nullch);
2098                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2099                 }
2100                 DIE(aTHX_ "Goto undefined subroutine");
2101             }
2102
2103             /* First do some returnish stuff. */
2104             cxix = dopoptosub(cxstack_ix);
2105             if (cxix < 0)
2106                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2107             if (cxix < cxstack_ix)
2108                 dounwind(cxix);
2109             TOPBLOCK(cx);
2110             if (CxREALEVAL(cx))
2111                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2112             mark = PL_stack_sp;
2113             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2114                 /* put @_ back onto stack */
2115                 AV* av = cx->blk_sub.argarray;
2116
2117                 items = AvFILLp(av) + 1;
2118                 PL_stack_sp++;
2119                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2120                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2121                 PL_stack_sp += items;
2122                 SvREFCNT_dec(GvAV(PL_defgv));
2123                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2124                 /* abandon @_ if it got reified */
2125                 if (AvREAL(av)) {
2126                     (void)sv_2mortal((SV*)av);  /* delay until return */
2127                     av = newAV();
2128                     av_extend(av, items-1);
2129                     AvFLAGS(av) = AVf_REIFY;
2130                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2131                 }
2132             }
2133             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2134                 AV* av;
2135                 av = GvAV(PL_defgv);
2136                 items = AvFILLp(av) + 1;
2137                 PL_stack_sp++;
2138                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2139                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2140                 PL_stack_sp += items;
2141             }
2142             if (CxTYPE(cx) == CXt_SUB &&
2143                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2144                 SvREFCNT_dec(cx->blk_sub.cv);
2145             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2146             LEAVE_SCOPE(oldsave);
2147
2148             /* Now do some callish stuff. */
2149             SAVETMPS;
2150             if (CvXSUB(cv)) {
2151 #ifdef PERL_XSUB_OLDSTYLE
2152                 if (CvOLDSTYLE(cv)) {
2153                     I32 (*fp3)(int,int,int);
2154                     while (SP > mark) {
2155                         SP[1] = SP[0];
2156                         SP--;
2157                     }
2158                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2159                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2160                                    mark - PL_stack_base + 1,
2161                                    items);
2162                     SP = PL_stack_base + items;
2163                 }
2164                 else
2165 #endif /* PERL_XSUB_OLDSTYLE */
2166                 {
2167                     SV **newsp;
2168                     I32 gimme;
2169
2170                     PL_stack_sp--;              /* There is no cv arg. */
2171                     /* Push a mark for the start of arglist */
2172                     PUSHMARK(mark);
2173                     (void)(*CvXSUB(cv))(aTHX_ cv);
2174                     /* Pop the current context like a decent sub should */
2175                     POPBLOCK(cx, PL_curpm);
2176                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2177                 }
2178                 LEAVE;
2179                 return pop_return();
2180             }
2181             else {
2182                 AV* padlist = CvPADLIST(cv);
2183                 if (CxTYPE(cx) == CXt_EVAL) {
2184                     PL_in_eval = cx->blk_eval.old_in_eval;
2185                     PL_eval_root = cx->blk_eval.old_eval_root;
2186                     cx->cx_type = CXt_SUB;
2187                     cx->blk_sub.hasargs = 0;
2188                 }
2189                 cx->blk_sub.cv = cv;
2190                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2191
2192                 CvDEPTH(cv)++;
2193                 if (CvDEPTH(cv) < 2)
2194                     (void)SvREFCNT_inc(cv);
2195                 else {
2196                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2197                         sub_crush_depth(cv);
2198                     pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2199                 }
2200                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2201                 if (cx->blk_sub.hasargs)
2202                 {
2203                     AV* av = (AV*)PAD_SVl(0);
2204                     SV** ary;
2205
2206                     cx->blk_sub.savearray = GvAV(PL_defgv);
2207                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2208                     CX_CURPAD_SAVE(cx->blk_sub);
2209                     cx->blk_sub.argarray = av;
2210                     ++mark;
2211
2212                     if (items >= AvMAX(av) + 1) {
2213                         ary = AvALLOC(av);
2214                         if (AvARRAY(av) != ary) {
2215                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2216                             SvPVX(av) = (char*)ary;
2217                         }
2218                         if (items >= AvMAX(av) + 1) {
2219                             AvMAX(av) = items - 1;
2220                             Renew(ary,items+1,SV*);
2221                             AvALLOC(av) = ary;
2222                             SvPVX(av) = (char*)ary;
2223                         }
2224                     }
2225                     Copy(mark,AvARRAY(av),items,SV*);
2226                     AvFILLp(av) = items - 1;
2227                     assert(!AvREAL(av));
2228                     while (items--) {
2229                         if (*mark)
2230                             SvTEMP_off(*mark);
2231                         mark++;
2232                     }
2233                 }
2234                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2235                     /*
2236                      * We do not care about using sv to call CV;
2237                      * it's for informational purposes only.
2238                      */
2239                     SV *sv = GvSV(PL_DBsub);
2240                     CV *gotocv;
2241
2242                     if (PERLDB_SUB_NN) {
2243                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2244                     } else {
2245                         save_item(sv);
2246                         gv_efullname3(sv, CvGV(cv), Nullch);
2247                     }
2248                     if (  PERLDB_GOTO
2249                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2250                         PUSHMARK( PL_stack_sp );
2251                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2252                         PL_stack_sp--;
2253                     }
2254                 }
2255                 RETURNOP(CvSTART(cv));
2256             }
2257         }
2258         else {
2259             label = SvPV(sv,n_a);
2260             if (!(do_dump || *label))
2261                 DIE(aTHX_ must_have_label);
2262         }
2263     }
2264     else if (PL_op->op_flags & OPf_SPECIAL) {
2265         if (! do_dump)
2266             DIE(aTHX_ must_have_label);
2267     }
2268     else
2269         label = cPVOP->op_pv;
2270
2271     if (label && *label) {
2272         OP *gotoprobe = 0;
2273         bool leaving_eval = FALSE;
2274         PERL_CONTEXT *last_eval_cx = 0;
2275
2276         /* find label */
2277
2278         PL_lastgotoprobe = 0;
2279         *enterops = 0;
2280         for (ix = cxstack_ix; ix >= 0; ix--) {
2281             cx = &cxstack[ix];
2282             switch (CxTYPE(cx)) {
2283             case CXt_EVAL:
2284                 leaving_eval = TRUE;
2285                 if (CxREALEVAL(cx)) {
2286                     gotoprobe = (last_eval_cx ?
2287                                 last_eval_cx->blk_eval.old_eval_root :
2288                                 PL_eval_root);
2289                     last_eval_cx = cx;
2290                     break;
2291                 }
2292                 /* else fall through */
2293             case CXt_LOOP:
2294                 gotoprobe = cx->blk_oldcop->op_sibling;
2295                 break;
2296             case CXt_SUBST:
2297                 continue;
2298             case CXt_BLOCK:
2299                 if (ix)
2300                     gotoprobe = cx->blk_oldcop->op_sibling;
2301                 else
2302                     gotoprobe = PL_main_root;
2303                 break;
2304             case CXt_SUB:
2305                 if (CvDEPTH(cx->blk_sub.cv)) {
2306                     gotoprobe = CvROOT(cx->blk_sub.cv);
2307                     break;
2308                 }
2309                 /* FALL THROUGH */
2310             case CXt_FORMAT:
2311             case CXt_NULL:
2312                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2313             default:
2314                 if (ix)
2315                     DIE(aTHX_ "panic: goto");
2316                 gotoprobe = PL_main_root;
2317                 break;
2318             }
2319             if (gotoprobe) {
2320                 retop = dofindlabel(gotoprobe, label,
2321                                     enterops, enterops + GOTO_DEPTH);
2322                 if (retop)
2323                     break;
2324             }
2325             PL_lastgotoprobe = gotoprobe;
2326         }
2327         if (!retop)
2328             DIE(aTHX_ "Can't find label %s", label);
2329
2330         /* if we're leaving an eval, check before we pop any frames
2331            that we're not going to punt, otherwise the error
2332            won't be caught */
2333
2334         if (leaving_eval && *enterops && enterops[1]) {
2335             I32 i;
2336             for (i = 1; enterops[i]; i++)
2337                 if (enterops[i]->op_type == OP_ENTERITER)
2338                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2339         }
2340
2341         /* pop unwanted frames */
2342
2343         if (ix < cxstack_ix) {
2344             I32 oldsave;
2345
2346             if (ix < 0)
2347                 ix = 0;
2348             dounwind(ix);
2349             TOPBLOCK(cx);
2350             oldsave = PL_scopestack[PL_scopestack_ix];
2351             LEAVE_SCOPE(oldsave);
2352         }
2353
2354         /* push wanted frames */
2355
2356         if (*enterops && enterops[1]) {
2357             OP *oldop = PL_op;
2358             for (ix = 1; enterops[ix]; ix++) {
2359                 PL_op = enterops[ix];
2360                 /* Eventually we may want to stack the needed arguments
2361                  * for each op.  For now, we punt on the hard ones. */
2362                 if (PL_op->op_type == OP_ENTERITER)
2363                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2364                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2365             }
2366             PL_op = oldop;
2367         }
2368     }
2369
2370     if (do_dump) {
2371 #ifdef VMS
2372         if (!retop) retop = PL_main_start;
2373 #endif
2374         PL_restartop = retop;
2375         PL_do_undump = TRUE;
2376
2377         my_unexec();
2378
2379         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2380         PL_do_undump = FALSE;
2381     }
2382
2383     RETURNOP(retop);
2384 }
2385
2386 PP(pp_exit)
2387 {
2388     dSP;
2389     I32 anum;
2390
2391     if (MAXARG < 1)
2392         anum = 0;
2393     else {
2394         anum = SvIVx(POPs);
2395 #ifdef VMS
2396         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2397             anum = 0;
2398         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2399 #endif
2400     }
2401     PL_exit_flags |= PERL_EXIT_EXPECTED;
2402     my_exit(anum);
2403     PUSHs(&PL_sv_undef);
2404     RETURN;
2405 }
2406
2407 #ifdef NOTYET
2408 PP(pp_nswitch)
2409 {
2410     dSP;
2411     NV value = SvNVx(GvSV(cCOP->cop_gv));
2412     register I32 match = I_32(value);
2413
2414     if (value < 0.0) {
2415         if (((NV)match) > value)
2416             --match;            /* was fractional--truncate other way */
2417     }
2418     match -= cCOP->uop.scop.scop_offset;
2419     if (match < 0)
2420         match = 0;
2421     else if (match > cCOP->uop.scop.scop_max)
2422         match = cCOP->uop.scop.scop_max;
2423     PL_op = cCOP->uop.scop.scop_next[match];
2424     RETURNOP(PL_op);
2425 }
2426
2427 PP(pp_cswitch)
2428 {
2429     dSP;
2430     register I32 match;
2431
2432     if (PL_multiline)
2433         PL_op = PL_op->op_next;                 /* can't assume anything */
2434     else {
2435         STRLEN n_a;
2436         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2437         match -= cCOP->uop.scop.scop_offset;
2438         if (match < 0)
2439             match = 0;
2440         else if (match > cCOP->uop.scop.scop_max)
2441             match = cCOP->uop.scop.scop_max;
2442         PL_op = cCOP->uop.scop.scop_next[match];
2443     }
2444     RETURNOP(PL_op);
2445 }
2446 #endif
2447
2448 /* Eval. */
2449
2450 STATIC void
2451 S_save_lines(pTHX_ AV *array, SV *sv)
2452 {
2453     register char *s = SvPVX(sv);
2454     register char *send = SvPVX(sv) + SvCUR(sv);
2455     register char *t;
2456     register I32 line = 1;
2457
2458     while (s && s < send) {
2459         SV *tmpstr = NEWSV(85,0);
2460
2461         sv_upgrade(tmpstr, SVt_PVMG);
2462         t = strchr(s, '\n');
2463         if (t)
2464             t++;
2465         else
2466             t = send;
2467
2468         sv_setpvn(tmpstr, s, t - s);
2469         av_store(array, line++, tmpstr);
2470         s = t;
2471     }
2472 }
2473
2474 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2475 STATIC void *
2476 S_docatch_body(pTHX_ va_list args)
2477 {
2478     return docatch_body();
2479 }
2480 #endif
2481
2482 STATIC void *
2483 S_docatch_body(pTHX)
2484 {
2485     CALLRUNOPS(aTHX);
2486     return NULL;
2487 }
2488
2489 STATIC OP *
2490 S_docatch(pTHX_ OP *o)
2491 {
2492     int ret;
2493     OP *oldop = PL_op;
2494     OP *retop;
2495     volatile PERL_SI *cursi = PL_curstackinfo;
2496     dJMPENV;
2497
2498 #ifdef DEBUGGING
2499     assert(CATCH_GET == TRUE);
2500 #endif
2501     PL_op = o;
2502
2503     /* Normally, the leavetry at the end of this block of ops will
2504      * pop an op off the return stack and continue there. By setting
2505      * the op to Nullop, we force an exit from the inner runops()
2506      * loop. DAPM.
2507      */
2508     retop = pop_return();
2509     push_return(Nullop);
2510
2511 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2512  redo_body:
2513     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2514 #else
2515     JMPENV_PUSH(ret);
2516 #endif
2517     switch (ret) {
2518     case 0:
2519 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2520  redo_body:
2521         docatch_body();
2522 #endif
2523         break;
2524     case 3:
2525         /* die caught by an inner eval - continue inner loop */
2526         if (PL_restartop && cursi == PL_curstackinfo) {
2527             PL_op = PL_restartop;
2528             PL_restartop = 0;
2529             goto redo_body;
2530         }
2531         /* a die in this eval - continue in outer loop */
2532         if (!PL_restartop)
2533             break;
2534         /* FALL THROUGH */
2535     default:
2536         JMPENV_POP;
2537         PL_op = oldop;
2538         JMPENV_JUMP(ret);
2539         /* NOTREACHED */
2540     }
2541     JMPENV_POP;
2542     PL_op = oldop;
2543     return retop;
2544 }
2545
2546 OP *
2547 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2548 /* sv Text to convert to OP tree. */
2549 /* startop op_free() this to undo. */
2550 /* code Short string id of the caller. */
2551 {
2552     dSP;                                /* Make POPBLOCK work. */
2553     PERL_CONTEXT *cx;
2554     SV **newsp;
2555     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2556     I32 optype;
2557     OP dummy;
2558     OP *rop;
2559     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2560     char *tmpbuf = tbuf;
2561     char *safestr;
2562     int runtime;
2563     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2564
2565     ENTER;
2566     lex_start(sv);
2567     SAVETMPS;
2568     /* switch to eval mode */
2569
2570     if (PL_curcop == &PL_compiling) {
2571         SAVECOPSTASH_FREE(&PL_compiling);
2572         CopSTASH_set(&PL_compiling, PL_curstash);
2573     }
2574     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2575         SV *sv = sv_newmortal();
2576         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2577                        code, (unsigned long)++PL_evalseq,
2578                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2579         tmpbuf = SvPVX(sv);
2580     }
2581     else
2582         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2583     SAVECOPFILE_FREE(&PL_compiling);
2584     CopFILE_set(&PL_compiling, tmpbuf+2);
2585     SAVECOPLINE(&PL_compiling);
2586     CopLINE_set(&PL_compiling, 1);
2587     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2588        deleting the eval's FILEGV from the stash before gv_check() runs
2589        (i.e. before run-time proper). To work around the coredump that
2590        ensues, we always turn GvMULTI_on for any globals that were
2591        introduced within evals. See force_ident(). GSAR 96-10-12 */
2592     safestr = savepv(tmpbuf);
2593     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2594     SAVEHINTS();
2595 #ifdef OP_IN_REGISTER
2596     PL_opsave = op;
2597 #else
2598     SAVEVPTR(PL_op);
2599 #endif
2600     PL_hints &= HINT_UTF8;
2601
2602     /* we get here either during compilation, or via pp_regcomp at runtime */
2603     runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2604     if (runtime)
2605         runcv = find_runcv(NULL);
2606
2607     PL_op = &dummy;
2608     PL_op->op_type = OP_ENTEREVAL;
2609     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2610     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2611     PUSHEVAL(cx, 0, Nullgv);
2612
2613     if (runtime)
2614         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2615     else
2616         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2617     POPBLOCK(cx,PL_curpm);
2618     POPEVAL(cx);
2619
2620     (*startop)->op_type = OP_NULL;
2621     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2622     lex_end();
2623     /* XXX DAPM do this properly one year */
2624     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2625     LEAVE;
2626     if (PL_curcop == &PL_compiling)
2627         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2628 #ifdef OP_IN_REGISTER
2629     op = PL_opsave;
2630 #endif
2631     return rop;
2632 }
2633
2634
2635 /*
2636 =for apidoc find_runcv
2637
2638 Locate the CV corresponding to the currently executing sub or eval.
2639 If db_seqp is non_null, skip CVs that are in the DB package and populate
2640 *db_seqp with the cop sequence number at the point that the DB:: code was
2641 entered. (allows debuggers to eval in the scope of the breakpoint rather
2642 than in in the scope of the debuger itself).
2643
2644 =cut
2645 */
2646
2647 CV*
2648 Perl_find_runcv(pTHX_ U32 *db_seqp)
2649 {
2650     I32          ix;
2651     PERL_SI      *si;
2652     PERL_CONTEXT *cx;
2653
2654     if (db_seqp)
2655         *db_seqp = PL_curcop->cop_seq;
2656     for (si = PL_curstackinfo; si; si = si->si_prev) {
2657         for (ix = si->si_cxix; ix >= 0; ix--) {
2658             cx = &(si->si_cxstack[ix]);
2659             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2660                 CV *cv = cx->blk_sub.cv;
2661                 /* skip DB:: code */
2662                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2663                     *db_seqp = cx->blk_oldcop->cop_seq;
2664                     continue;
2665                 }
2666                 return cv;
2667             }
2668             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2669                 return PL_compcv;
2670         }
2671     }
2672     return PL_main_cv;
2673 }
2674
2675
2676 /* Compile a require/do, an eval '', or a /(?{...})/.
2677  * In the last case, startop is non-null, and contains the address of
2678  * a pointer that should be set to the just-compiled code.
2679  * outside is the lexically enclosing CV (if any) that invoked us.
2680  */
2681
2682 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2683 STATIC OP *
2684 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2685 {
2686     dSP;
2687     OP *saveop = PL_op;
2688
2689     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2690                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2691                   : EVAL_INEVAL);
2692
2693     PUSHMARK(SP);
2694
2695     SAVESPTR(PL_compcv);
2696     PL_compcv = (CV*)NEWSV(1104,0);
2697     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2698     CvEVAL_on(PL_compcv);
2699     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2700     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2701
2702     CvOUTSIDE_SEQ(PL_compcv) = seq;
2703     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2704
2705     /* set up a scratch pad */
2706
2707     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2708
2709
2710     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2711
2712     /* make sure we compile in the right package */
2713
2714     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2715         SAVESPTR(PL_curstash);
2716         PL_curstash = CopSTASH(PL_curcop);
2717     }
2718     SAVESPTR(PL_beginav);
2719     PL_beginav = newAV();
2720     SAVEFREESV(PL_beginav);
2721     SAVEI32(PL_error_count);
2722
2723     /* try to compile it */
2724
2725     PL_eval_root = Nullop;
2726     PL_error_count = 0;
2727     PL_curcop = &PL_compiling;
2728     PL_curcop->cop_arybase = 0;
2729     if (saveop && saveop->op_flags & OPf_SPECIAL)
2730         PL_in_eval |= EVAL_KEEPERR;
2731     else
2732         sv_setpv(ERRSV,"");
2733     if (yyparse() || PL_error_count || !PL_eval_root) {
2734         SV **newsp;
2735         I32 gimme;
2736         PERL_CONTEXT *cx;
2737         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2738         STRLEN n_a;
2739
2740         PL_op = saveop;
2741         if (PL_eval_root) {
2742             op_free(PL_eval_root);
2743             PL_eval_root = Nullop;
2744         }
2745         SP = PL_stack_base + POPMARK;           /* pop original mark */
2746         if (!startop) {
2747             POPBLOCK(cx,PL_curpm);
2748             POPEVAL(cx);
2749             pop_return();
2750         }
2751         lex_end();
2752         LEAVE;
2753         if (optype == OP_REQUIRE) {
2754             char* msg = SvPVx(ERRSV, n_a);
2755             DIE(aTHX_ "%sCompilation failed in require",
2756                 *msg ? msg : "Unknown error\n");
2757         }
2758         else if (startop) {
2759             char* msg = SvPVx(ERRSV, n_a);
2760
2761             POPBLOCK(cx,PL_curpm);
2762             POPEVAL(cx);
2763             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2764                        (*msg ? msg : "Unknown error\n"));
2765         }
2766         else {
2767             char* msg = SvPVx(ERRSV, n_a);
2768             if (!*msg) {
2769                 sv_setpv(ERRSV, "Compilation error");
2770             }
2771         }
2772         RETPUSHUNDEF;
2773     }
2774     CopLINE_set(&PL_compiling, 0);
2775     if (startop) {
2776         *startop = PL_eval_root;
2777     } else
2778         SAVEFREEOP(PL_eval_root);
2779     if (gimme & G_VOID)
2780         scalarvoid(PL_eval_root);
2781     else if (gimme & G_ARRAY)
2782         list(PL_eval_root);
2783     else
2784         scalar(PL_eval_root);
2785
2786     DEBUG_x(dump_eval());
2787
2788     /* Register with debugger: */
2789     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2790         CV *cv = get_cv("DB::postponed", FALSE);
2791         if (cv) {
2792             dSP;
2793             PUSHMARK(SP);
2794             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2795             PUTBACK;
2796             call_sv((SV*)cv, G_DISCARD);
2797         }
2798     }
2799
2800     /* compiled okay, so do it */
2801
2802     CvDEPTH(PL_compcv) = 1;
2803     SP = PL_stack_base + POPMARK;               /* pop original mark */
2804     PL_op = saveop;                     /* The caller may need it. */
2805     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2806
2807     RETURNOP(PL_eval_start);
2808 }
2809
2810 STATIC PerlIO *
2811 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2812 {
2813     STRLEN namelen = strlen(name);
2814     PerlIO *fp;
2815
2816     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2817         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2818         char *pmc = SvPV_nolen(pmcsv);
2819         Stat_t pmstat;
2820         Stat_t pmcstat;
2821         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2822             fp = PerlIO_open(name, mode);
2823         }
2824         else {
2825             if (PerlLIO_stat(name, &pmstat) < 0 ||
2826                 pmstat.st_mtime < pmcstat.st_mtime)
2827             {
2828                 fp = PerlIO_open(pmc, mode);
2829             }
2830             else {
2831                 fp = PerlIO_open(name, mode);
2832             }
2833         }
2834         SvREFCNT_dec(pmcsv);
2835     }
2836     else {
2837         fp = PerlIO_open(name, mode);
2838     }
2839     return fp;
2840 }
2841
2842 PP(pp_require)
2843 {
2844     dSP;
2845     register PERL_CONTEXT *cx;
2846     SV *sv;
2847     char *name;
2848     STRLEN len;
2849     char *tryname = Nullch;
2850     SV *namesv = Nullsv;
2851     SV** svp;
2852     I32 gimme = GIMME_V;
2853     PerlIO *tryrsfp = 0;
2854     STRLEN n_a;
2855     int filter_has_file = 0;
2856     GV *filter_child_proc = 0;
2857     SV *filter_state = 0;
2858     SV *filter_sub = 0;
2859     SV *hook_sv = 0;
2860     SV *encoding;
2861     OP *op;
2862
2863     sv = POPs;
2864     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2865         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2866             UV rev = 0, ver = 0, sver = 0;
2867             STRLEN len;
2868             U8 *s = (U8*)SvPVX(sv);
2869             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2870             if (s < end) {
2871                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2872                 s += len;
2873                 if (s < end) {
2874                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
2875                     s += len;
2876                     if (s < end)
2877                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
2878                 }
2879             }
2880             if (PERL_REVISION < rev
2881                 || (PERL_REVISION == rev
2882                     && (PERL_VERSION < ver
2883                         || (PERL_VERSION == ver
2884                             && PERL_SUBVERSION < sver))))
2885             {
2886                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2887                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2888                     PERL_VERSION, PERL_SUBVERSION);
2889             }
2890             if (ckWARN(WARN_PORTABLE))
2891                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2892                         "v-string in use/require non-portable");
2893             RETPUSHYES;
2894         }
2895         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
2896             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2897                 + ((NV)PERL_SUBVERSION/(NV)1000000)
2898                 + 0.00000099 < SvNV(sv))
2899             {
2900                 NV nrev = SvNV(sv);
2901                 UV rev = (UV)nrev;
2902                 NV nver = (nrev - rev) * 1000;
2903                 UV ver = (UV)(nver + 0.0009);
2904                 NV nsver = (nver - ver) * 1000;
2905                 UV sver = (UV)(nsver + 0.0009);
2906
2907                 /* help out with the "use 5.6" confusion */
2908                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2909                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2910                         " (did you mean v%"UVuf".%03"UVuf"?)--"
2911                         "this is only v%d.%d.%d, stopped",
2912                         rev, ver, sver, rev, ver/100,
2913                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2914                 }
2915                 else {
2916                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2917                         "this is only v%d.%d.%d, stopped",
2918                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
2919                         PERL_SUBVERSION);
2920                 }
2921             }
2922             RETPUSHYES;
2923         }
2924     }
2925     name = SvPV(sv, len);
2926     if (!(name && len > 0 && *name))
2927         DIE(aTHX_ "Null filename used");
2928     TAINT_PROPER("require");
2929     if (PL_op->op_type == OP_REQUIRE &&
2930       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2931       *svp != &PL_sv_undef)
2932         RETPUSHYES;
2933
2934     /* prepare to compile file */
2935
2936     if (path_is_absolute(name)) {
2937         tryname = name;
2938         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2939     }
2940 #ifdef MACOS_TRADITIONAL
2941     if (!tryrsfp) {
2942         char newname[256];
2943
2944         MacPerl_CanonDir(name, newname, 1);
2945         if (path_is_absolute(newname)) {
2946             tryname = newname;
2947             tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2948         }
2949     }
2950 #endif
2951     if (!tryrsfp) {
2952         AV *ar = GvAVn(PL_incgv);
2953         I32 i;
2954 #ifdef VMS
2955         char *unixname;
2956         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2957 #endif
2958         {
2959             namesv = NEWSV(806, 0);
2960             for (i = 0; i <= AvFILL(ar); i++) {
2961                 SV *dirsv = *av_fetch(ar, i, TRUE);
2962
2963                 if (SvROK(dirsv)) {
2964                     int count;
2965                     SV *loader = dirsv;
2966
2967                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
2968                         && !sv_isobject(loader))
2969                     {
2970                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2971                     }
2972
2973                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2974                                    PTR2UV(SvRV(dirsv)), name);
2975                     tryname = SvPVX(namesv);
2976                     tryrsfp = 0;
2977
2978                     ENTER;
2979                     SAVETMPS;
2980                     EXTEND(SP, 2);
2981
2982                     PUSHMARK(SP);
2983                     PUSHs(dirsv);
2984                     PUSHs(sv);
2985                     PUTBACK;
2986                     if (sv_isobject(loader))
2987                         count = call_method("INC", G_ARRAY);
2988                     else
2989                         count = call_sv(loader, G_ARRAY);
2990                     SPAGAIN;
2991
2992                     if (count > 0) {
2993                         int i = 0;
2994                         SV *arg;
2995
2996                         SP -= count - 1;
2997                         arg = SP[i++];
2998
2999                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3000                             arg = SvRV(arg);
3001                         }
3002
3003                         if (SvTYPE(arg) == SVt_PVGV) {
3004                             IO *io = GvIO((GV *)arg);
3005
3006                             ++filter_has_file;
3007
3008                             if (io) {
3009                                 tryrsfp = IoIFP(io);
3010                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3011                                     /* reading from a child process doesn't
3012                                        nest -- when returning from reading
3013                                        the inner module, the outer one is
3014                                        unreadable (closed?)  I've tried to
3015                                        save the gv to manage the lifespan of
3016                                        the pipe, but this didn't help. XXX */
3017                                     filter_child_proc = (GV *)arg;
3018                                     (void)SvREFCNT_inc(filter_child_proc);
3019                                 }
3020                                 else {
3021                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3022                                         PerlIO_close(IoOFP(io));
3023                                     }
3024                                     IoIFP(io) = Nullfp;
3025                                     IoOFP(io) = Nullfp;
3026                                 }
3027                             }
3028
3029                             if (i < count) {
3030                                 arg = SP[i++];
3031                             }
3032                         }
3033
3034                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3035                             filter_sub = arg;
3036                             (void)SvREFCNT_inc(filter_sub);
3037
3038                             if (i < count) {
3039                                 filter_state = SP[i];
3040                                 (void)SvREFCNT_inc(filter_state);
3041                             }
3042
3043                             if (tryrsfp == 0) {
3044                                 tryrsfp = PerlIO_open("/dev/null",
3045                                                       PERL_SCRIPT_MODE);
3046                             }
3047                         }
3048                     }
3049
3050                     PUTBACK;
3051                     FREETMPS;
3052                     LEAVE;
3053
3054                     if (tryrsfp) {
3055                         hook_sv = dirsv;
3056                         break;
3057                     }
3058
3059                     filter_has_file = 0;
3060                     if (filter_child_proc) {
3061                         SvREFCNT_dec(filter_child_proc);
3062                         filter_child_proc = 0;
3063                     }
3064                     if (filter_state) {
3065                         SvREFCNT_dec(filter_state);
3066                         filter_state = 0;
3067                     }
3068                     if (filter_sub) {
3069                         SvREFCNT_dec(filter_sub);
3070                         filter_sub = 0;
3071                     }
3072                 }
3073                 else {
3074                   if (!path_is_absolute(name)
3075 #ifdef MACOS_TRADITIONAL
3076                         /* We consider paths of the form :a:b ambiguous and interpret them first
3077                            as global then as local
3078                         */
3079                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3080 #endif
3081                   ) {
3082                     char *dir = SvPVx(dirsv, n_a);
3083 #ifdef MACOS_TRADITIONAL
3084                     char buf1[256];
3085                     char buf2[256];
3086
3087                     MacPerl_CanonDir(name, buf2, 1);
3088                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3089 #else
3090 #ifdef VMS
3091                     char *unixdir;
3092                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3093                         continue;
3094                     sv_setpv(namesv, unixdir);
3095                     sv_catpv(namesv, unixname);
3096 #else
3097                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3098 #endif
3099 #endif
3100                     TAINT_PROPER("require");
3101                     tryname = SvPVX(namesv);
3102                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3103                     if (tryrsfp) {
3104                         if (tryname[0] == '.' && tryname[1] == '/')
3105                             tryname += 2;
3106                         break;
3107                     }
3108                   }
3109                 }
3110             }
3111         }
3112     }
3113     SAVECOPFILE_FREE(&PL_compiling);
3114     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3115     SvREFCNT_dec(namesv);
3116     if (!tryrsfp) {
3117         if (PL_op->op_type == OP_REQUIRE) {
3118             char *msgstr = name;
3119             if (namesv) {                       /* did we lookup @INC? */
3120                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3121                 SV *dirmsgsv = NEWSV(0, 0);
3122                 AV *ar = GvAVn(PL_incgv);
3123                 I32 i;
3124                 sv_catpvn(msg, " in @INC", 8);
3125                 if (instr(SvPVX(msg), ".h "))
3126                     sv_catpv(msg, " (change .h to .ph maybe?)");
3127                 if (instr(SvPVX(msg), ".ph "))
3128                     sv_catpv(msg, " (did you run h2ph?)");
3129                 sv_catpv(msg, " (@INC contains:");
3130                 for (i = 0; i <= AvFILL(ar); i++) {
3131                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3132                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3133                     sv_catsv(msg, dirmsgsv);
3134                 }
3135                 sv_catpvn(msg, ")", 1);
3136                 SvREFCNT_dec(dirmsgsv);
3137                 msgstr = SvPV_nolen(msg);
3138             }
3139             DIE(aTHX_ "Can't locate %s", msgstr);
3140         }
3141
3142         RETPUSHUNDEF;
3143     }
3144     else
3145         SETERRNO(0, SS_NORMAL);
3146
3147     /* Assume success here to prevent recursive requirement. */
3148     len = strlen(name);
3149     /* Check whether a hook in @INC has already filled %INC */
3150     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3151         (void)hv_store(GvHVn(PL_incgv), name, len,
3152                        (hook_sv ? SvREFCNT_inc(hook_sv)
3153                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3154                        0 );
3155     }
3156
3157     ENTER;
3158     SAVETMPS;
3159     lex_start(sv_2mortal(newSVpvn("",0)));
3160     SAVEGENERICSV(PL_rsfp_filters);
3161     PL_rsfp_filters = Nullav;
3162
3163     PL_rsfp = tryrsfp;
3164     SAVEHINTS();
3165     PL_hints = 0;
3166     SAVESPTR(PL_compiling.cop_warnings);
3167     if (PL_dowarn & G_WARN_ALL_ON)
3168         PL_compiling.cop_warnings = pWARN_ALL ;
3169     else if (PL_dowarn & G_WARN_ALL_OFF)
3170         PL_compiling.cop_warnings = pWARN_NONE ;
3171     else if (PL_taint_warn)
3172         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3173     else
3174         PL_compiling.cop_warnings = pWARN_STD ;
3175     SAVESPTR(PL_compiling.cop_io);
3176     PL_compiling.cop_io = Nullsv;
3177
3178     if (filter_sub || filter_child_proc) {
3179         SV *datasv = filter_add(run_user_filter, Nullsv);
3180         IoLINES(datasv) = filter_has_file;
3181         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3182         IoTOP_GV(datasv) = (GV *)filter_state;
3183         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3184     }
3185
3186     /* switch to eval mode */
3187     push_return(PL_op->op_next);
3188     PUSHBLOCK(cx, CXt_EVAL, SP);
3189     PUSHEVAL(cx, name, Nullgv);
3190
3191     SAVECOPLINE(&PL_compiling);
3192     CopLINE_set(&PL_compiling, 0);
3193
3194     PUTBACK;
3195
3196     /* Store and reset encoding. */
3197     encoding = PL_encoding;
3198     PL_encoding = Nullsv;
3199
3200     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3201
3202     /* Restore encoding. */
3203     PL_encoding = encoding;
3204
3205     return op;
3206 }
3207
3208 PP(pp_dofile)
3209 {
3210     return pp_require();
3211 }
3212
3213 PP(pp_entereval)
3214 {
3215     dSP;
3216     register PERL_CONTEXT *cx;
3217     dPOPss;
3218     I32 gimme = GIMME_V, was = PL_sub_generation;
3219     char tbuf[TYPE_DIGITS(long) + 12];
3220     char *tmpbuf = tbuf;
3221     char *safestr;
3222     STRLEN len;
3223     OP *ret;
3224     CV* runcv;
3225     U32 seq;
3226
3227     if (!SvPV(sv,len))
3228         RETPUSHUNDEF;
3229     TAINT_PROPER("eval");
3230
3231     ENTER;
3232     lex_start(sv);
3233     SAVETMPS;
3234
3235     /* switch to eval mode */
3236
3237     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3238         SV *sv = sv_newmortal();
3239         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3240                        (unsigned long)++PL_evalseq,
3241                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3242         tmpbuf = SvPVX(sv);
3243     }
3244     else
3245         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3246     SAVECOPFILE_FREE(&PL_compiling);
3247     CopFILE_set(&PL_compiling, tmpbuf+2);
3248     SAVECOPLINE(&PL_compiling);
3249     CopLINE_set(&PL_compiling, 1);
3250     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3251        deleting the eval's FILEGV from the stash before gv_check() runs
3252        (i.e. before run-time proper). To work around the coredump that
3253        ensues, we always turn GvMULTI_on for any globals that were
3254        introduced within evals. See force_ident(). GSAR 96-10-12 */
3255     safestr = savepv(tmpbuf);
3256     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3257     SAVEHINTS();
3258     PL_hints = PL_op->op_targ;
3259     SAVESPTR(PL_compiling.cop_warnings);
3260     if (specialWARN(PL_curcop->cop_warnings))
3261         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3262     else {
3263         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3264         SAVEFREESV(PL_compiling.cop_warnings);
3265     }
3266     SAVESPTR(PL_compiling.cop_io);
3267     if (specialCopIO(PL_curcop->cop_io))
3268         PL_compiling.cop_io = PL_curcop->cop_io;
3269     else {
3270         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3271         SAVEFREESV(PL_compiling.cop_io);
3272     }
3273     /* special case: an eval '' executed within the DB package gets lexically
3274      * placed in the first non-DB CV rather than the current CV - this
3275      * allows the debugger to execute code, find lexicals etc, in the
3276      * scope of the code being debugged. Passing &seq gets find_runcv
3277      * to do the dirty work for us */
3278     runcv = find_runcv(&seq);
3279
3280     push_return(PL_op->op_next);
3281     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3282     PUSHEVAL(cx, 0, Nullgv);
3283
3284     /* prepare to compile string */
3285
3286     if (PERLDB_LINE && PL_curstash != PL_debstash)
3287         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3288     PUTBACK;
3289     ret = doeval(gimme, NULL, runcv, seq);
3290     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3291         && ret != PL_op->op_next) {     /* Successive compilation. */
3292         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3293     }
3294     return DOCATCH(ret);
3295 }
3296
3297 PP(pp_leaveeval)
3298 {
3299     dSP;
3300     register SV **mark;
3301     SV **newsp;
3302     PMOP *newpm;
3303     I32 gimme;
3304     register PERL_CONTEXT *cx;
3305     OP *retop;
3306     U8 save_flags = PL_op -> op_flags;
3307     I32 optype;
3308
3309     POPBLOCK(cx,newpm);
3310     POPEVAL(cx);
3311     retop = pop_return();
3312
3313     TAINT_NOT;
3314     if (gimme == G_VOID)
3315         MARK = newsp;
3316     else if (gimme == G_SCALAR) {
3317         MARK = newsp + 1;
3318         if (MARK <= SP) {
3319             if (SvFLAGS(TOPs) & SVs_TEMP)
3320                 *MARK = TOPs;
3321             else
3322                 *MARK = sv_mortalcopy(TOPs);
3323         }
3324         else {
3325             MEXTEND(mark,0);
3326             *MARK = &PL_sv_undef;
3327         }
3328         SP = MARK;
3329     }
3330     else {
3331         /* in case LEAVE wipes old return values */
3332         for (mark = newsp + 1; mark <= SP; mark++) {
3333             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3334                 *mark = sv_mortalcopy(*mark);
3335                 TAINT_NOT;      /* Each item is independent */
3336             }
3337         }
3338     }
3339     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3340
3341 #ifdef DEBUGGING
3342     assert(CvDEPTH(PL_compcv) == 1);
3343 #endif
3344     CvDEPTH(PL_compcv) = 0;
3345     lex_end();
3346
3347     if (optype == OP_REQUIRE &&
3348         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3349     {
3350         /* Unassume the success we assumed earlier. */
3351         SV *nsv = cx->blk_eval.old_namesv;
3352         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3353         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3354         /* die_where() did LEAVE, or we won't be here */
3355     }
3356     else {
3357         LEAVE;
3358         if (!(save_flags & OPf_SPECIAL))
3359             sv_setpv(ERRSV,"");
3360     }
3361
3362     RETURNOP(retop);
3363 }
3364
3365 PP(pp_entertry)
3366 {
3367     dSP;
3368     register PERL_CONTEXT *cx;
3369     I32 gimme = GIMME_V;
3370
3371     ENTER;
3372     SAVETMPS;
3373
3374     push_return(cLOGOP->op_other->op_next);
3375     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3376     PUSHEVAL(cx, 0, 0);
3377
3378     PL_in_eval = EVAL_INEVAL;
3379     sv_setpv(ERRSV,"");
3380     PUTBACK;
3381     return DOCATCH(PL_op->op_next);
3382 }
3383
3384 PP(pp_leavetry)
3385 {
3386     dSP;
3387     register SV **mark;
3388     SV **newsp;
3389     PMOP *newpm;
3390     OP* retop;
3391     I32 gimme;
3392     register PERL_CONTEXT *cx;
3393     I32 optype;
3394
3395     POPBLOCK(cx,newpm);
3396     POPEVAL(cx);
3397     retop = pop_return();
3398
3399     TAINT_NOT;
3400     if (gimme == G_VOID)
3401         SP = newsp;
3402     else if (gimme == G_SCALAR) {
3403         MARK = newsp + 1;
3404         if (MARK <= SP) {
3405             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3406                 *MARK = TOPs;
3407             else
3408                 *MARK = sv_mortalcopy(TOPs);
3409         }
3410         else {
3411             MEXTEND(mark,0);
3412             *MARK = &PL_sv_undef;
3413         }
3414         SP = MARK;
3415     }
3416     else {
3417         /* in case LEAVE wipes old return values */
3418         for (mark = newsp + 1; mark <= SP; mark++) {
3419             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3420                 *mark = sv_mortalcopy(*mark);
3421                 TAINT_NOT;      /* Each item is independent */
3422             }
3423         }
3424     }
3425     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3426
3427     LEAVE;
3428     sv_setpv(ERRSV,"");
3429     RETURNOP(retop);
3430 }
3431
3432 STATIC void
3433 S_doparseform(pTHX_ SV *sv)
3434 {
3435     STRLEN len;
3436     register char *s = SvPV_force(sv, len);
3437     register char *send = s + len;
3438     register char *base = Nullch;
3439     register I32 skipspaces = 0;
3440     bool noblank   = FALSE;
3441     bool repeat    = FALSE;
3442     bool postspace = FALSE;
3443     U16 *fops;
3444     register U16 *fpc;
3445     U16 *linepc = 0;
3446     register I32 arg;
3447     bool ischop;
3448
3449     if (len == 0)
3450         Perl_croak(aTHX_ "Null picture in formline");
3451
3452     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3453     fpc = fops;
3454
3455     if (s < send) {
3456         linepc = fpc;
3457         *fpc++ = FF_LINEMARK;
3458         noblank = repeat = FALSE;
3459         base = s;
3460     }
3461
3462     while (s <= send) {
3463         switch (*s++) {
3464         default:
3465             skipspaces = 0;
3466             continue;
3467
3468         case '~':
3469             if (*s == '~') {
3470                 repeat = TRUE;
3471                 *s = ' ';
3472             }
3473             noblank = TRUE;
3474             s[-1] = ' ';
3475             /* FALL THROUGH */
3476         case ' ': case '\t':
3477             skipspaces++;
3478             continue;
3479
3480         case '\n': case 0:
3481             arg = s - base;
3482             skipspaces++;
3483             arg -= skipspaces;
3484             if (arg) {
3485                 if (postspace)
3486                     *fpc++ = FF_SPACE;
3487                 *fpc++ = FF_LITERAL;
3488                 *fpc++ = (U16)arg;
3489             }
3490             postspace = FALSE;
3491             if (s <= send)
3492                 skipspaces--;
3493             if (skipspaces) {
3494                 *fpc++ = FF_SKIP;
3495                 *fpc++ = (U16)skipspaces;
3496             }
3497             skipspaces = 0;
3498             if (s <= send)
3499                 *fpc++ = FF_NEWLINE;
3500             if (noblank) {
3501                 *fpc++ = FF_BLANK;
3502                 if (repeat)
3503                     arg = fpc - linepc + 1;
3504                 else
3505                     arg = 0;
3506                 *fpc++ = (U16)arg;
3507             }
3508             if (s < send) {
3509                 linepc = fpc;
3510                 *fpc++ = FF_LINEMARK;
3511                 noblank = repeat = FALSE;
3512                 base = s;
3513             }
3514             else
3515                 s++;
3516             continue;
3517
3518         case '@':
3519         case '^':
3520             ischop = s[-1] == '^';
3521
3522             if (postspace) {
3523                 *fpc++ = FF_SPACE;
3524                 postspace = FALSE;
3525             }
3526             arg = (s - base) - 1;
3527             if (arg) {
3528                 *fpc++ = FF_LITERAL;
3529                 *fpc++ = (U16)arg;
3530             }
3531
3532             base = s - 1;
3533             *fpc++ = FF_FETCH;
3534             if (*s == '*') {
3535                 s++;
3536                 *fpc++ = 0;
3537                 *fpc++ = FF_LINEGLOB;
3538             }
3539             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3540                 arg = ischop ? 512 : 0;
3541                 base = s - 1;
3542                 while (*s == '#')
3543                     s++;
3544                 if (*s == '.') {
3545                     char *f;
3546                     s++;
3547                     f = s;
3548                     while (*s == '#')
3549                         s++;
3550                     arg |= 256 + (s - f);
3551                 }
3552                 *fpc++ = s - base;              /* fieldsize for FETCH */
3553                 *fpc++ = FF_DECIMAL;
3554                 *fpc++ = (U16)arg;
3555             }
3556             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3557                 arg = ischop ? 512 : 0;
3558                 base = s - 1;
3559                 s++;                                /* skip the '0' first */
3560                 while (*s == '#')
3561                     s++;
3562                 if (*s == '.') {
3563                     char *f;
3564                     s++;
3565                     f = s;
3566                     while (*s == '#')
3567                         s++;
3568                     arg |= 256 + (s - f);
3569                 }
3570                 *fpc++ = s - base;                /* fieldsize for FETCH */
3571                 *fpc++ = FF_0DECIMAL;
3572                 *fpc++ = (U16)arg;
3573             }
3574             else {
3575                 I32 prespace = 0;
3576                 bool ismore = FALSE;
3577
3578                 if (*s == '>') {
3579                     while (*++s == '>') ;
3580                     prespace = FF_SPACE;
3581                 }
3582                 else if (*s == '|') {
3583                     while (*++s == '|') ;
3584                     prespace = FF_HALFSPACE;
3585                     postspace = TRUE;
3586                 }
3587                 else {
3588                     if (*s == '<')
3589                         while (*++s == '<') ;
3590                     postspace = TRUE;
3591                 }
3592                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3593                     s += 3;
3594                     ismore = TRUE;
3595                 }
3596                 *fpc++ = s - base;              /* fieldsize for FETCH */
3597
3598                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3599
3600                 if (prespace)
3601                     *fpc++ = (U16)prespace;
3602                 *fpc++ = FF_ITEM;
3603                 if (ismore)
3604                     *fpc++ = FF_MORE;
3605                 if (ischop)
3606                     *fpc++ = FF_CHOP;
3607             }
3608             base = s;
3609             skipspaces = 0;
3610             continue;
3611         }
3612     }
3613     *fpc++ = FF_END;
3614
3615     arg = fpc - fops;
3616     { /* need to jump to the next word */
3617         int z;
3618         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3619         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3620         s = SvPVX(sv) + SvCUR(sv) + z;
3621     }
3622     Copy(fops, s, arg, U16);
3623     Safefree(fops);
3624     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3625     SvCOMPILED_on(sv);
3626 }
3627
3628 static I32
3629 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3630 {
3631     SV *datasv = FILTER_DATA(idx);
3632     int filter_has_file = IoLINES(datasv);
3633     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3634     SV *filter_state = (SV *)IoTOP_GV(datasv);
3635     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3636     int len = 0;
3637
3638     /* I was having segfault trouble under Linux 2.2.5 after a
3639        parse error occured.  (Had to hack around it with a test
3640        for PL_error_count == 0.)  Solaris doesn't segfault --
3641        not sure where the trouble is yet.  XXX */
3642
3643     if (filter_has_file) {
3644         len = FILTER_READ(idx+1, buf_sv, maxlen);
3645     }
3646
3647     if (filter_sub && len >= 0) {
3648         dSP;
3649         int count;
3650
3651         ENTER;
3652         SAVE_DEFSV;
3653         SAVETMPS;
3654         EXTEND(SP, 2);
3655
3656         DEFSV = buf_sv;
3657         PUSHMARK(SP);
3658         PUSHs(sv_2mortal(newSViv(maxlen)));
3659         if (filter_state) {
3660             PUSHs(filter_state);
3661         }
3662         PUTBACK;
3663         count = call_sv(filter_sub, G_SCALAR);
3664         SPAGAIN;
3665
3666         if (count > 0) {
3667             SV *out = POPs;
3668             if (SvOK(out)) {
3669                 len = SvIV(out);
3670             }
3671         }
3672
3673         PUTBACK;
3674         FREETMPS;
3675         LEAVE;
3676     }
3677
3678     if (len <= 0) {
3679         IoLINES(datasv) = 0;
3680         if (filter_child_proc) {
3681             SvREFCNT_dec(filter_child_proc);
3682             IoFMT_GV(datasv) = Nullgv;
3683         }
3684         if (filter_state) {
3685             SvREFCNT_dec(filter_state);
3686             IoTOP_GV(datasv) = Nullgv;
3687         }
3688         if (filter_sub) {
3689             SvREFCNT_dec(filter_sub);
3690             IoBOTTOM_GV(datasv) = Nullgv;
3691         }
3692         filter_del(run_user_filter);
3693     }
3694
3695     return len;
3696 }
3697
3698 /* perhaps someone can come up with a better name for
3699    this?  it is not really "absolute", per se ... */
3700 static bool
3701 S_path_is_absolute(pTHX_ char *name)
3702 {
3703     if (PERL_FILE_IS_ABSOLUTE(name)
3704 #ifdef MACOS_TRADITIONAL
3705         || (*name == ':'))
3706 #else
3707         || (*name == '.' && (name[1] == '/' ||
3708                              (name[1] == '.' && name[2] == '/'))))
3709 #endif
3710     {
3711         return TRUE;
3712     }
3713     else
3714         return FALSE;
3715 }