pp_ctl.c

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