pp_ctl.c

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