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 I32
1019 S_dopoptolabel(pTHX_ char *label)
1020 {
1021     register I32 i;
1022     register PERL_CONTEXT *cx;
1023
1024     for (i = cxstack_ix; i >= 0; i--) {
1025         cx = &cxstack[i];
1026         switch (CxTYPE(cx)) {
1027         case CXt_SUBST:
1028             if (ckWARN(WARN_EXITING))
1029                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
1030                         OP_NAME(PL_op));
1031             break;
1032         case CXt_SUB:
1033             if (ckWARN(WARN_EXITING))
1034                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
1035                         OP_NAME(PL_op));
1036             break;
1037         case CXt_FORMAT:
1038             if (ckWARN(WARN_EXITING))
1039                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
1040                         OP_NAME(PL_op));
1041             break;
1042         case CXt_EVAL:
1043             if (ckWARN(WARN_EXITING))
1044                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
1045                         OP_NAME(PL_op));
1046             break;
1047         case CXt_NULL:
1048             if (ckWARN(WARN_EXITING))
1049                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
1050                         OP_NAME(PL_op));
1051             return -1;
1052         case CXt_LOOP:
1053             if (!cx->blk_loop.label ||
1054               strNE(label, cx->blk_loop.label) ) {
1055                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1056                         (long)i, cx->blk_loop.label));
1057                 continue;
1058             }
1059             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1060             return i;
1061         }
1062     }
1063     return i;
1064 }
1065
1066 I32
1067 Perl_dowantarray(pTHX)
1068 {
1069     I32 gimme = block_gimme();
1070     return (gimme == G_VOID) ? G_SCALAR : gimme;
1071 }
1072
1073 I32
1074 Perl_block_gimme(pTHX)
1075 {
1076     I32 cxix;
1077
1078     cxix = dopoptosub(cxstack_ix);
1079     if (cxix < 0)
1080         return G_VOID;
1081
1082     switch (cxstack[cxix].blk_gimme) {
1083     case G_VOID:
1084         return G_VOID;
1085     case G_SCALAR:
1086         return G_SCALAR;
1087     case G_ARRAY:
1088         return G_ARRAY;
1089     default:
1090         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1091         /* NOTREACHED */
1092         return 0;
1093     }
1094 }
1095
1096 I32
1097 Perl_is_lvalue_sub(pTHX)
1098 {
1099     I32 cxix;
1100
1101     cxix = dopoptosub(cxstack_ix);
1102     assert(cxix >= 0);  /* We should only be called from inside subs */
1103
1104     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1105         return cxstack[cxix].blk_sub.lval;
1106     else
1107         return 0;
1108 }
1109
1110 STATIC I32
1111 S_dopoptosub(pTHX_ I32 startingblock)
1112 {
1113     return dopoptosub_at(cxstack, startingblock);
1114 }
1115
1116 STATIC I32
1117 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1118 {
1119     I32 i;
1120     register PERL_CONTEXT *cx;
1121     for (i = startingblock; i >= 0; i--) {
1122         cx = &cxstk[i];
1123         switch (CxTYPE(cx)) {
1124         default:
1125             continue;
1126         case CXt_EVAL:
1127         case CXt_SUB:
1128         case CXt_FORMAT:
1129             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1130             return i;
1131         }
1132     }
1133     return i;
1134 }
1135
1136 STATIC I32
1137 S_dopoptoeval(pTHX_ I32 startingblock)
1138 {
1139     I32 i;
1140     register PERL_CONTEXT *cx;
1141     for (i = startingblock; i >= 0; i--) {
1142         cx = &cxstack[i];
1143         switch (CxTYPE(cx)) {
1144         default:
1145             continue;
1146         case CXt_EVAL:
1147             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1148             return i;
1149         }
1150     }
1151     return i;
1152 }
1153
1154 STATIC I32
1155 S_dopoptoloop(pTHX_ I32 startingblock)
1156 {
1157     I32 i;
1158     register PERL_CONTEXT *cx;
1159     for (i = startingblock; i >= 0; i--) {
1160         cx = &cxstack[i];
1161         switch (CxTYPE(cx)) {
1162         case CXt_SUBST:
1163             if (ckWARN(WARN_EXITING))
1164                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
1165                         OP_NAME(PL_op));
1166             break;
1167         case CXt_SUB:
1168             if (ckWARN(WARN_EXITING))
1169                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
1170                         OP_NAME(PL_op));
1171             break;
1172         case CXt_FORMAT:
1173             if (ckWARN(WARN_EXITING))
1174                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
1175                         OP_NAME(PL_op));
1176             break;
1177         case CXt_EVAL:
1178             if (ckWARN(WARN_EXITING))
1179                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
1180                         OP_NAME(PL_op));
1181             break;
1182         case CXt_NULL:
1183             if (ckWARN(WARN_EXITING))
1184                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
1185                         OP_NAME(PL_op));
1186             return -1;
1187         case CXt_LOOP:
1188             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1189             return i;
1190         }
1191     }
1192     return i;
1193 }
1194
1195 void
1196 Perl_dounwind(pTHX_ I32 cxix)
1197 {
1198     register PERL_CONTEXT *cx;
1199     I32 optype;
1200
1201     while (cxstack_ix > cxix) {
1202         SV *sv;
1203         cx = &cxstack[cxstack_ix];
1204         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1205                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1206         /* Note: we don't need to restore the base context info till the end. */
1207         switch (CxTYPE(cx)) {
1208         case CXt_SUBST:
1209             POPSUBST(cx);
1210             continue;  /* not break */
1211         case CXt_SUB:
1212             POPSUB(cx,sv);
1213             LEAVESUB(sv);
1214             break;
1215         case CXt_EVAL:
1216             POPEVAL(cx);
1217             break;
1218         case CXt_LOOP:
1219             POPLOOP(cx);
1220             break;
1221         case CXt_NULL:
1222             break;
1223         case CXt_FORMAT:
1224             POPFORMAT(cx);
1225             break;
1226         }
1227         cxstack_ix--;
1228     }
1229 }
1230
1231 void
1232 Perl_qerror(pTHX_ SV *err)
1233 {
1234     if (PL_in_eval)
1235         sv_catsv(ERRSV, err);
1236     else if (PL_errors)
1237         sv_catsv(PL_errors, err);
1238     else
1239         Perl_warn(aTHX_ "%"SVf, err);
1240     ++PL_error_count;
1241 }
1242
1243 OP *
1244 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1245 {
1246     STRLEN n_a;
1247     IO *io;
1248     MAGIC *mg;
1249
1250     if (PL_in_eval) {
1251         I32 cxix;
1252         register PERL_CONTEXT *cx;
1253         I32 gimme;
1254         SV **newsp;
1255
1256         if (message) {
1257             if (PL_in_eval & EVAL_KEEPERR) {
1258                 static char prefix[] = "\t(in cleanup) ";
1259                 SV *err = ERRSV;
1260                 char *e = Nullch;
1261                 if (!SvPOK(err))
1262                     sv_setpv(err,"");
1263                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1264                     e = SvPV(err, n_a);
1265                     e += n_a - msglen;
1266                     if (*e != *message || strNE(e,message))
1267                         e = Nullch;
1268                 }
1269                 if (!e) {
1270                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1271                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1272                     sv_catpvn(err, message, msglen);
1273                     if (ckWARN(WARN_MISC)) {
1274                         STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1275                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1276                     }
1277                 }
1278             }
1279             else {
1280                 sv_setpvn(ERRSV, message, msglen);
1281             }
1282         }
1283         else
1284             message = SvPVx(ERRSV, msglen);
1285
1286         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1287                && PL_curstackinfo->si_prev)
1288         {
1289             dounwind(-1);
1290             POPSTACK;
1291         }
1292
1293         if (cxix >= 0) {
1294             I32 optype;
1295
1296             if (cxix < cxstack_ix)
1297                 dounwind(cxix);
1298
1299             POPBLOCK(cx,PL_curpm);
1300             if (CxTYPE(cx) != CXt_EVAL) {
1301                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1302                 PerlIO_write(Perl_error_log, message, msglen);
1303                 my_exit(1);
1304             }
1305             POPEVAL(cx);
1306
1307             if (gimme == G_SCALAR)
1308                 *++newsp = &PL_sv_undef;
1309             PL_stack_sp = newsp;
1310
1311             LEAVE;
1312
1313             /* LEAVE could clobber PL_curcop (see save_re_context())
1314              * XXX it might be better to find a way to avoid messing with
1315              * PL_curcop in save_re_context() instead, but this is a more
1316              * minimal fix --GSAR */
1317             PL_curcop = cx->blk_oldcop;
1318
1319             if (optype == OP_REQUIRE) {
1320                 char* msg = SvPVx(ERRSV, n_a);
1321                 DIE(aTHX_ "%sCompilation failed in require",
1322                     *msg ? msg : "Unknown error\n");
1323             }
1324             return pop_return();
1325         }
1326     }
1327     if (!message)
1328         message = SvPVx(ERRSV, msglen);
1329
1330     /* if STDERR is tied, print to it instead */
1331     if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1332         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1333         dSP; ENTER;
1334         PUSHMARK(SP);
1335         XPUSHs(SvTIED_obj((SV*)io, mg));
1336         XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1337         PUTBACK;
1338         call_method("PRINT", G_SCALAR);
1339         LEAVE;
1340     }
1341     else {
1342 #ifdef USE_SFIO
1343         /* SFIO can really mess with your errno */
1344         int e = errno;
1345 #endif
1346         PerlIO *serr = Perl_error_log;
1347
1348         PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1349         (void)PerlIO_flush(serr);
1350 #ifdef USE_SFIO
1351         errno = e;
1352 #endif
1353     }
1354     my_failure_exit();
1355     /* NOTREACHED */
1356     return 0;
1357 }
1358
1359 PP(pp_xor)
1360 {
1361     dSP; dPOPTOPssrl;
1362     if (SvTRUE(left) != SvTRUE(right))
1363         RETSETYES;
1364     else
1365         RETSETNO;
1366 }
1367
1368 PP(pp_andassign)
1369 {
1370     dSP;
1371     if (!SvTRUE(TOPs))
1372         RETURN;
1373     else
1374         RETURNOP(cLOGOP->op_other);
1375 }
1376
1377 PP(pp_orassign)
1378 {
1379     dSP;
1380     if (SvTRUE(TOPs))
1381         RETURN;
1382     else
1383         RETURNOP(cLOGOP->op_other);
1384 }
1385
1386 PP(pp_dorassign)
1387 {
1388     dSP;
1389     register SV* sv;
1390
1391     sv = TOPs;
1392     if (!sv || !SvANY(sv)) {
1393         RETURNOP(cLOGOP->op_other);
1394     }
1395
1396     switch (SvTYPE(sv)) {
1397     case SVt_PVAV:
1398         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1399             RETURN;
1400         break;
1401     case SVt_PVHV:
1402         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1403             RETURN;
1404         break;
1405     case SVt_PVCV:
1406         if (CvROOT(sv) || CvXSUB(sv))
1407             RETURN;
1408         break;
1409     default:
1410         if (SvGMAGICAL(sv))
1411             mg_get(sv);
1412         if (SvOK(sv))
1413             RETURN;
1414     }
1415
1416     RETURNOP(cLOGOP->op_other);
1417 }
1418
1419 PP(pp_caller)
1420 {
1421     dSP;
1422     register I32 cxix = dopoptosub(cxstack_ix);
1423     register PERL_CONTEXT *cx;
1424     register PERL_CONTEXT *ccstack = cxstack;
1425     PERL_SI *top_si = PL_curstackinfo;
1426     I32 dbcxix;
1427     I32 gimme;
1428     char *stashname;
1429     SV *sv;
1430     I32 count = 0;
1431
1432     if (MAXARG)
1433         count = POPi;
1434
1435     for (;;) {
1436         /* we may be in a higher stacklevel, so dig down deeper */
1437         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1438             top_si = top_si->si_prev;
1439             ccstack = top_si->si_cxstack;
1440             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1441         }
1442         if (cxix < 0) {
1443             if (GIMME != G_ARRAY) {
1444                 EXTEND(SP, 1);
1445                 RETPUSHUNDEF;
1446             }
1447             RETURN;
1448         }
1449         if (PL_DBsub && cxix >= 0 &&
1450                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1451             count++;
1452         if (!count--)
1453             break;
1454         cxix = dopoptosub_at(ccstack, cxix - 1);
1455     }
1456
1457     cx = &ccstack[cxix];
1458     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1459         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1460         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1461            field below is defined for any cx. */
1462         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1463             cx = &ccstack[dbcxix];
1464     }
1465
1466     stashname = CopSTASHPV(cx->blk_oldcop);
1467     if (GIMME != G_ARRAY) {
1468         EXTEND(SP, 1);
1469         if (!stashname)
1470             PUSHs(&PL_sv_undef);
1471         else {
1472             dTARGET;
1473             sv_setpv(TARG, stashname);
1474             PUSHs(TARG);
1475         }
1476         RETURN;
1477     }
1478
1479     EXTEND(SP, 10);
1480
1481     if (!stashname)
1482         PUSHs(&PL_sv_undef);
1483     else
1484         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1485     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1486     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1487     if (!MAXARG)
1488         RETURN;
1489     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1490         GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1491         /* So is ccstack[dbcxix]. */
1492         if (isGV(cvgv)) {
1493             sv = NEWSV(49, 0);
1494             gv_efullname3(sv, cvgv, Nullch);
1495             PUSHs(sv_2mortal(sv));
1496             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1497         }
1498         else {
1499             PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1500             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1501         }
1502     }
1503     else {
1504         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1505         PUSHs(sv_2mortal(newSViv(0)));
1506     }
1507     gimme = (I32)cx->blk_gimme;
1508     if (gimme == G_VOID)
1509         PUSHs(&PL_sv_undef);
1510     else
1511         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1512     if (CxTYPE(cx) == CXt_EVAL) {
1513         /* eval STRING */
1514         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1515             PUSHs(cx->blk_eval.cur_text);
1516             PUSHs(&PL_sv_no);
1517         }
1518         /* require */
1519         else if (cx->blk_eval.old_namesv) {
1520             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1521             PUSHs(&PL_sv_yes);
1522         }
1523         /* eval BLOCK (try blocks have old_namesv == 0) */
1524         else {
1525             PUSHs(&PL_sv_undef);
1526             PUSHs(&PL_sv_undef);
1527         }
1528     }
1529     else {
1530         PUSHs(&PL_sv_undef);
1531         PUSHs(&PL_sv_undef);
1532     }
1533     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1534         && CopSTASH_eq(PL_curcop, PL_debstash))
1535     {
1536         AV *ary = cx->blk_sub.argarray;
1537         int off = AvARRAY(ary) - AvALLOC(ary);
1538
1539         if (!PL_dbargs) {
1540             GV* tmpgv;
1541             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1542                                 SVt_PVAV)));
1543             GvMULTI_on(tmpgv);
1544             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1545         }
1546
1547         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1548             av_extend(PL_dbargs, AvFILLp(ary) + off);
1549         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1550         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1551     }
1552     /* XXX only hints propagated via op_private are currently
1553      * visible (others are not easily accessible, since they
1554      * use the global PL_hints) */
1555     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1556                              HINT_PRIVATE_MASK)));
1557     {
1558         SV * mask ;
1559         SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1560
1561         if  (old_warnings == pWARN_NONE ||
1562                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1563             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1564         else if (old_warnings == pWARN_ALL ||
1565                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1566             mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1567         else
1568             mask = newSVsv(old_warnings);
1569         PUSHs(sv_2mortal(mask));
1570     }
1571     RETURN;
1572 }
1573
1574 PP(pp_reset)
1575 {
1576     dSP;
1577     char *tmps;
1578     STRLEN n_a;
1579
1580     if (MAXARG < 1)
1581         tmps = "";
1582     else
1583         tmps = POPpx;
1584     sv_reset(tmps, CopSTASH(PL_curcop));
1585     PUSHs(&PL_sv_yes);
1586     RETURN;
1587 }
1588
1589 PP(pp_lineseq)
1590 {
1591     return NORMAL;
1592 }
1593
1594 /* like pp_nextstate, but used instead when the debugger is active */
1595
1596 PP(pp_dbstate)
1597 {
1598     PL_curcop = (COP*)PL_op;
1599     TAINT_NOT;          /* Each statement is presumed innocent */
1600     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1601     FREETMPS;
1602
1603     if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1604     {
1605         dSP;
1606         register CV *cv;
1607         register PERL_CONTEXT *cx;
1608         I32 gimme = G_ARRAY;
1609         U8 hasargs;
1610         GV *gv;
1611
1612         gv = PL_DBgv;
1613         cv = GvCV(gv);
1614         if (!cv)
1615             DIE(aTHX_ "No DB::DB routine defined");
1616
1617         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1618             /* don't do recursive DB::DB call */
1619             return NORMAL;
1620
1621         ENTER;
1622         SAVETMPS;
1623
1624         SAVEI32(PL_debug);
1625         SAVESTACK_POS();
1626         PL_debug = 0;
1627         hasargs = 0;
1628         SPAGAIN;
1629
1630         push_return(PL_op->op_next);
1631         PUSHBLOCK(cx, CXt_SUB, SP);
1632         PUSHSUB(cx);
1633         CvDEPTH(cv)++;
1634         (void)SvREFCNT_inc(cv);
1635         PAD_SET_CUR(CvPADLIST(cv),1);
1636         RETURNOP(CvSTART(cv));
1637     }
1638     else
1639         return NORMAL;
1640 }
1641
1642 PP(pp_scope)
1643 {
1644     return NORMAL;
1645 }
1646
1647 PP(pp_enteriter)
1648 {
1649     dSP; dMARK;
1650     register PERL_CONTEXT *cx;
1651     I32 gimme = GIMME_V;
1652     SV **svp;
1653     U32 cxtype = CXt_LOOP;
1654 #ifdef USE_ITHREADS
1655     void *iterdata;
1656 #endif
1657
1658     ENTER;
1659     SAVETMPS;
1660
1661     if (PL_op->op_targ) {
1662 #ifndef USE_ITHREADS
1663         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1664         SAVESPTR(*svp);
1665 #else
1666         SAVEPADSV(PL_op->op_targ);
1667         iterdata = INT2PTR(void*, PL_op->op_targ);
1668         cxtype |= CXp_PADVAR;
1669 #endif
1670     }
1671     else {
1672         GV *gv = (GV*)POPs;
1673         svp = &GvSV(gv);                        /* symbol table variable */
1674         SAVEGENERICSV(*svp);
1675         *svp = NEWSV(0,0);
1676 #ifdef USE_ITHREADS
1677         iterdata = (void*)gv;
1678 #endif
1679     }
1680
1681     ENTER;
1682
1683     PUSHBLOCK(cx, cxtype, SP);
1684 #ifdef USE_ITHREADS
1685     PUSHLOOP(cx, iterdata, MARK);
1686 #else
1687     PUSHLOOP(cx, svp, MARK);
1688 #endif
1689     if (PL_op->op_flags & OPf_STACKED) {
1690         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1691         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1692             dPOPss;
1693             /* See comment in pp_flop() */
1694             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1695                 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1696                 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1697                  looks_like_number((SV*)cx->blk_loop.iterary)))
1698             {
1699                  if (SvNV(sv) < IV_MIN ||
1700                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1701                      DIE(aTHX_ "Range iterator outside integer range");
1702                  cx->blk_loop.iterix = SvIV(sv);
1703                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1704             }
1705             else
1706                 cx->blk_loop.iterlval = newSVsv(sv);
1707         }
1708     }
1709     else {
1710         cx->blk_loop.iterary = PL_curstack;
1711         AvFILLp(PL_curstack) = SP - PL_stack_base;
1712         cx->blk_loop.iterix = MARK - PL_stack_base;
1713     }
1714
1715     RETURN;
1716 }
1717
1718 PP(pp_enterloop)
1719 {
1720     dSP;
1721     register PERL_CONTEXT *cx;
1722     I32 gimme = GIMME_V;
1723
1724     ENTER;
1725     SAVETMPS;
1726     ENTER;
1727
1728     PUSHBLOCK(cx, CXt_LOOP, SP);
1729     PUSHLOOP(cx, 0, SP);
1730
1731     RETURN;
1732 }
1733
1734 PP(pp_leaveloop)
1735 {
1736     dSP;
1737     register PERL_CONTEXT *cx;
1738     I32 gimme;
1739     SV **newsp;
1740     PMOP *newpm;
1741     SV **mark;
1742
1743     POPBLOCK(cx,newpm);
1744     mark = newsp;
1745     newsp = PL_stack_base + cx->blk_loop.resetsp;
1746
1747     TAINT_NOT;
1748     if (gimme == G_VOID)
1749         ; /* do nothing */
1750     else if (gimme == G_SCALAR) {
1751         if (mark < SP)
1752             *++newsp = sv_mortalcopy(*SP);
1753         else
1754             *++newsp = &PL_sv_undef;
1755     }
1756     else {
1757         while (mark < SP) {
1758             *++newsp = sv_mortalcopy(*++mark);
1759             TAINT_NOT;          /* Each item is independent */
1760         }
1761     }
1762     SP = newsp;
1763     PUTBACK;
1764
1765     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1766     PL_curpm = newpm;   /* ... and pop $1 et al */
1767
1768     LEAVE;
1769     LEAVE;
1770
1771     return NORMAL;
1772 }
1773
1774 PP(pp_return)
1775 {
1776     dSP; dMARK;
1777     I32 cxix;
1778     register PERL_CONTEXT *cx;
1779     bool popsub2 = FALSE;
1780     bool clear_errsv = FALSE;
1781     I32 gimme;
1782     SV **newsp;
1783     PMOP *newpm;
1784     I32 optype = 0;
1785     SV *sv;
1786
1787     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1788         if (cxstack_ix == PL_sortcxix
1789             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1790         {
1791             if (cxstack_ix > PL_sortcxix)
1792                 dounwind(PL_sortcxix);
1793             AvARRAY(PL_curstack)[1] = *SP;
1794             PL_stack_sp = PL_stack_base + 1;
1795             return 0;
1796         }
1797     }
1798
1799     cxix = dopoptosub(cxstack_ix);
1800     if (cxix < 0)
1801         DIE(aTHX_ "Can't return outside a subroutine");
1802     if (cxix < cxstack_ix)
1803         dounwind(cxix);
1804
1805     POPBLOCK(cx,newpm);
1806     switch (CxTYPE(cx)) {
1807     case CXt_SUB:
1808         popsub2 = TRUE;
1809         break;
1810     case CXt_EVAL:
1811         if (!(PL_in_eval & EVAL_KEEPERR))
1812             clear_errsv = TRUE;
1813         POPEVAL(cx);
1814         if (CxTRYBLOCK(cx))
1815             break;
1816         lex_end();
1817         if (optype == OP_REQUIRE &&
1818             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1819         {
1820             /* Unassume the success we assumed earlier. */
1821             SV *nsv = cx->blk_eval.old_namesv;
1822             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1823             DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1824         }
1825         break;
1826     case CXt_FORMAT:
1827         POPFORMAT(cx);
1828         break;
1829     default:
1830         DIE(aTHX_ "panic: return");
1831     }
1832
1833     TAINT_NOT;
1834     if (gimme == G_SCALAR) {
1835         if (MARK < SP) {
1836             if (popsub2) {
1837                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1838                     if (SvTEMP(TOPs)) {
1839                         *++newsp = SvREFCNT_inc(*SP);
1840                         FREETMPS;
1841                         sv_2mortal(*newsp);
1842                     }
1843                     else {
1844                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1845                         FREETMPS;
1846                         *++newsp = sv_mortalcopy(sv);
1847                         SvREFCNT_dec(sv);
1848                     }
1849                 }
1850                 else
1851                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1852             }
1853             else
1854                 *++newsp = sv_mortalcopy(*SP);
1855         }
1856         else
1857             *++newsp = &PL_sv_undef;
1858     }
1859     else if (gimme == G_ARRAY) {
1860         while (++MARK <= SP) {
1861             *++newsp = (popsub2 && SvTEMP(*MARK))
1862                         ? *MARK : sv_mortalcopy(*MARK);
1863             TAINT_NOT;          /* Each item is independent */
1864         }
1865     }
1866     PL_stack_sp = newsp;
1867
1868     /* Stack values are safe: */
1869     if (popsub2) {
1870         POPSUB(cx,sv);  /* release CV and @_ ... */
1871     }
1872     else
1873         sv = Nullsv;
1874     PL_curpm = newpm;   /* ... and pop $1 et al */
1875
1876     LEAVE;
1877     LEAVESUB(sv);
1878     if (clear_errsv)
1879         sv_setpv(ERRSV,"");
1880     return pop_return();
1881 }
1882
1883 PP(pp_last)
1884 {
1885     dSP;
1886     I32 cxix;
1887     register PERL_CONTEXT *cx;
1888     I32 pop2 = 0;
1889     I32 gimme;
1890     I32 optype;
1891     OP *nextop;
1892     SV **newsp;
1893     PMOP *newpm;
1894     SV **mark;
1895     SV *sv = Nullsv;
1896
1897     if (PL_op->op_flags & OPf_SPECIAL) {
1898         cxix = dopoptoloop(cxstack_ix);
1899         if (cxix < 0)
1900             DIE(aTHX_ "Can't \"last\" outside a loop block");
1901     }
1902     else {
1903         cxix = dopoptolabel(cPVOP->op_pv);
1904         if (cxix < 0)
1905             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1906     }
1907     if (cxix < cxstack_ix)
1908         dounwind(cxix);
1909
1910     POPBLOCK(cx,newpm);
1911     mark = newsp;
1912     switch (CxTYPE(cx)) {
1913     case CXt_LOOP:
1914         pop2 = CXt_LOOP;
1915         newsp = PL_stack_base + cx->blk_loop.resetsp;
1916         nextop = cx->blk_loop.last_op->op_next;
1917         break;
1918     case CXt_SUB:
1919         pop2 = CXt_SUB;
1920         nextop = pop_return();
1921         break;
1922     case CXt_EVAL:
1923         POPEVAL(cx);
1924         nextop = pop_return();
1925         break;
1926     case CXt_FORMAT:
1927         POPFORMAT(cx);
1928         nextop = pop_return();
1929         break;
1930     default:
1931         DIE(aTHX_ "panic: last");
1932     }
1933
1934     TAINT_NOT;
1935     if (gimme == G_SCALAR) {
1936         if (MARK < SP)
1937             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1938                         ? *SP : sv_mortalcopy(*SP);
1939         else
1940             *++newsp = &PL_sv_undef;
1941     }
1942     else if (gimme == G_ARRAY) {
1943         while (++MARK <= SP) {
1944             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1945                         ? *MARK : sv_mortalcopy(*MARK);
1946             TAINT_NOT;          /* Each item is independent */
1947         }
1948     }
1949     SP = newsp;
1950     PUTBACK;
1951
1952     /* Stack values are safe: */
1953     switch (pop2) {
1954     case CXt_LOOP:
1955         POPLOOP(cx);    /* release loop vars ... */
1956         LEAVE;
1957         break;
1958     case CXt_SUB:
1959         POPSUB(cx,sv);  /* release CV and @_ ... */
1960         break;
1961     }
1962     PL_curpm = newpm;   /* ... and pop $1 et al */
1963
1964     LEAVE;
1965     LEAVESUB(sv);
1966     return nextop;
1967 }
1968
1969 PP(pp_next)
1970 {
1971     I32 cxix;
1972     register PERL_CONTEXT *cx;
1973     I32 inner;
1974
1975     if (PL_op->op_flags & OPf_SPECIAL) {
1976         cxix = dopoptoloop(cxstack_ix);
1977         if (cxix < 0)
1978             DIE(aTHX_ "Can't \"next\" outside a loop block");
1979     }
1980     else {
1981         cxix = dopoptolabel(cPVOP->op_pv);
1982         if (cxix < 0)
1983             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1984     }
1985     if (cxix < cxstack_ix)
1986         dounwind(cxix);
1987
1988     /* clear off anything above the scope we're re-entering, but
1989      * save the rest until after a possible continue block */
1990     inner = PL_scopestack_ix;
1991     TOPBLOCK(cx);
1992     if (PL_scopestack_ix < inner)
1993         leave_scope(PL_scopestack[PL_scopestack_ix]);
1994     return cx->blk_loop.next_op;
1995 }
1996
1997 PP(pp_redo)
1998 {
1999     I32 cxix;
2000     register PERL_CONTEXT *cx;
2001     I32 oldsave;
2002
2003     if (PL_op->op_flags & OPf_SPECIAL) {
2004         cxix = dopoptoloop(cxstack_ix);
2005         if (cxix < 0)
2006             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2007     }
2008     else {
2009         cxix = dopoptolabel(cPVOP->op_pv);
2010         if (cxix < 0)
2011             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2012     }
2013     if (cxix < cxstack_ix)
2014         dounwind(cxix);
2015
2016     TOPBLOCK(cx);
2017     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2018     LEAVE_SCOPE(oldsave);
2019     return cx->blk_loop.redo_op;
2020 }
2021
2022 STATIC OP *
2023 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2024 {
2025     OP *kid = Nullop;
2026     OP **ops = opstack;
2027     static char too_deep[] = "Target of goto is too deeply nested";
2028
2029     if (ops >= oplimit)
2030         Perl_croak(aTHX_ too_deep);
2031     if (o->op_type == OP_LEAVE ||
2032         o->op_type == OP_SCOPE ||
2033         o->op_type == OP_LEAVELOOP ||
2034         o->op_type == OP_LEAVETRY)
2035     {
2036         *ops++ = cUNOPo->op_first;
2037         if (ops >= oplimit)
2038             Perl_croak(aTHX_ too_deep);
2039     }
2040     *ops = 0;
2041     if (o->op_flags & OPf_KIDS) {
2042         /* First try all the kids at this level, since that's likeliest. */
2043         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2044             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2045                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2046                 return kid;
2047         }
2048         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2049             if (kid == PL_lastgotoprobe)
2050                 continue;
2051             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2052                 (ops == opstack ||
2053                  (ops[-1]->op_type != OP_NEXTSTATE &&
2054                   ops[-1]->op_type != OP_DBSTATE)))
2055                 *ops++ = kid;
2056             if ((o = dofindlabel(kid, label, ops, oplimit)))
2057                 return o;
2058         }
2059     }
2060     *ops = 0;
2061     return 0;
2062 }
2063
2064 PP(pp_dump)
2065 {
2066     return pp_goto();
2067     /*NOTREACHED*/
2068 }
2069
2070 PP(pp_goto)
2071 {
2072     dSP;
2073     OP *retop = 0;
2074     I32 ix;
2075     register PERL_CONTEXT *cx;
2076 #define GOTO_DEPTH 64
2077     OP *enterops[GOTO_DEPTH];
2078     char *label;
2079     int do_dump = (PL_op->op_type == OP_DUMP);
2080     static char must_have_label[] = "goto must have label";
2081
2082     label = 0;
2083     if (PL_op->op_flags & OPf_STACKED) {
2084         SV *sv = POPs;
2085         STRLEN n_a;
2086
2087         /* This egregious kludge implements goto &subroutine */
2088         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2089             I32 cxix;
2090             register PERL_CONTEXT *cx;
2091             CV* cv = (CV*)SvRV(sv);
2092             SV** mark;
2093             I32 items = 0;
2094             I32 oldsave;
2095
2096         retry:
2097             if (!CvROOT(cv) && !CvXSUB(cv)) {
2098                 GV *gv = CvGV(cv);
2099                 GV *autogv;
2100                 if (gv) {
2101                     SV *tmpstr;
2102                     /* autoloaded stub? */
2103                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2104                         goto retry;
2105                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2106                                           GvNAMELEN(gv), FALSE);
2107                     if (autogv && (cv = GvCV(autogv)))
2108                         goto retry;
2109                     tmpstr = sv_newmortal();
2110                     gv_efullname3(tmpstr, gv, Nullch);
2111                     DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2112                 }
2113                 DIE(aTHX_ "Goto undefined subroutine");
2114             }
2115
2116             /* First do some returnish stuff. */
2117             cxix = dopoptosub(cxstack_ix);
2118             if (cxix < 0)
2119                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2120             if (cxix < cxstack_ix)
2121                 dounwind(cxix);
2122             TOPBLOCK(cx);
2123             if (CxREALEVAL(cx))
2124                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2125             mark = PL_stack_sp;
2126             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2127                 /* put @_ back onto stack */
2128                 AV* av = cx->blk_sub.argarray;
2129
2130                 items = AvFILLp(av) + 1;
2131                 PL_stack_sp++;
2132                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2133                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2134                 PL_stack_sp += items;
2135                 SvREFCNT_dec(GvAV(PL_defgv));
2136                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2137                 /* abandon @_ if it got reified */
2138                 if (AvREAL(av)) {
2139                     (void)sv_2mortal((SV*)av);  /* delay until return */
2140                     av = newAV();
2141                     av_extend(av, items-1);
2142                     AvFLAGS(av) = AVf_REIFY;
2143                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2144                 }
2145             }
2146             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2147                 AV* av;
2148                 av = GvAV(PL_defgv);
2149                 items = AvFILLp(av) + 1;
2150                 PL_stack_sp++;
2151                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2152                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2153                 PL_stack_sp += items;
2154             }
2155             if (CxTYPE(cx) == CXt_SUB &&
2156                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2157                 SvREFCNT_dec(cx->blk_sub.cv);
2158             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2159             LEAVE_SCOPE(oldsave);
2160
2161             /* Now do some callish stuff. */
2162             SAVETMPS;
2163             if (CvXSUB(cv)) {
2164 #ifdef PERL_XSUB_OLDSTYLE
2165                 if (CvOLDSTYLE(cv)) {
2166                     I32 (*fp3)(int,int,int);
2167                     while (SP > mark) {
2168                         SP[1] = SP[0];
2169                         SP--;
2170                     }
2171                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2172                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2173                                    mark - PL_stack_base + 1,
2174                                    items);
2175                     SP = PL_stack_base + items;
2176                 }
2177                 else
2178 #endif /* PERL_XSUB_OLDSTYLE */
2179                 {
2180                     SV **newsp;
2181                     I32 gimme;
2182
2183                     PL_stack_sp--;              /* There is no cv arg. */
2184                     /* Push a mark for the start of arglist */
2185                     PUSHMARK(mark);
2186                     (void)(*CvXSUB(cv))(aTHX_ cv);
2187                     /* Pop the current context like a decent sub should */
2188                     POPBLOCK(cx, PL_curpm);
2189                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2190                 }
2191                 LEAVE;
2192                 return pop_return();
2193             }
2194             else {
2195                 AV* padlist = CvPADLIST(cv);
2196                 if (CxTYPE(cx) == CXt_EVAL) {
2197                     PL_in_eval = cx->blk_eval.old_in_eval;
2198                     PL_eval_root = cx->blk_eval.old_eval_root;
2199                     cx->cx_type = CXt_SUB;
2200                     cx->blk_sub.hasargs = 0;
2201                 }
2202                 cx->blk_sub.cv = cv;
2203                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2204
2205                 CvDEPTH(cv)++;
2206                 if (CvDEPTH(cv) < 2)
2207                     (void)SvREFCNT_inc(cv);
2208                 else {
2209                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2210                         sub_crush_depth(cv);
2211                     pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2212                 }
2213                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2214                 if (cx->blk_sub.hasargs)
2215                 {
2216                     AV* av = (AV*)PAD_SVl(0);
2217                     SV** ary;
2218
2219                     cx->blk_sub.savearray = GvAV(PL_defgv);
2220                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2221                     CX_CURPAD_SAVE(cx->blk_sub);
2222                     cx->blk_sub.argarray = av;
2223                     ++mark;
2224
2225                     if (items >= AvMAX(av) + 1) {
2226                         ary = AvALLOC(av);
2227                         if (AvARRAY(av) != ary) {
2228                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2229                             SvPVX(av) = (char*)ary;
2230                         }
2231                         if (items >= AvMAX(av) + 1) {
2232                             AvMAX(av) = items - 1;
2233                             Renew(ary,items+1,SV*);
2234                             AvALLOC(av) = ary;
2235                             SvPVX(av) = (char*)ary;
2236                         }
2237                     }
2238                     Copy(mark,AvARRAY(av),items,SV*);
2239                     AvFILLp(av) = items - 1;
2240                     assert(!AvREAL(av));
2241                     while (items--) {
2242                         if (*mark)
2243                             SvTEMP_off(*mark);
2244                         mark++;
2245                     }
2246                 }
2247                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2248                     /*
2249                      * We do not care about using sv to call CV;
2250                      * it's for informational purposes only.
2251                      */
2252                     SV *sv = GvSV(PL_DBsub);
2253                     CV *gotocv;
2254
2255                     if (PERLDB_SUB_NN) {
2256                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2257                     } else {
2258                         save_item(sv);
2259                         gv_efullname3(sv, CvGV(cv), Nullch);
2260                     }
2261                     if (  PERLDB_GOTO
2262                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2263                         PUSHMARK( PL_stack_sp );
2264                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2265                         PL_stack_sp--;
2266                     }
2267                 }
2268                 RETURNOP(CvSTART(cv));
2269             }
2270         }
2271         else {
2272             label = SvPV(sv,n_a);
2273             if (!(do_dump || *label))
2274                 DIE(aTHX_ must_have_label);
2275         }
2276     }
2277     else if (PL_op->op_flags & OPf_SPECIAL) {
2278         if (! do_dump)
2279             DIE(aTHX_ must_have_label);
2280     }
2281     else
2282         label = cPVOP->op_pv;
2283
2284     if (label && *label) {
2285         OP *gotoprobe = 0;
2286         bool leaving_eval = FALSE;
2287         PERL_CONTEXT *last_eval_cx = 0;
2288
2289         /* find label */
2290
2291         PL_lastgotoprobe = 0;
2292         *enterops = 0;
2293         for (ix = cxstack_ix; ix >= 0; ix--) {
2294             cx = &cxstack[ix];
2295             switch (CxTYPE(cx)) {
2296             case CXt_EVAL:
2297                 leaving_eval = TRUE;
2298                 if (CxREALEVAL(cx)) {
2299                     gotoprobe = (last_eval_cx ?
2300                                 last_eval_cx->blk_eval.old_eval_root :
2301                                 PL_eval_root);
2302                     last_eval_cx = cx;
2303                     break;
2304                 }
2305                 /* else fall through */
2306             case CXt_LOOP:
2307                 gotoprobe = cx->blk_oldcop->op_sibling;
2308                 break;
2309             case CXt_SUBST:
2310                 continue;
2311             case CXt_BLOCK:
2312                 if (ix)
2313                     gotoprobe = cx->blk_oldcop->op_sibling;
2314                 else
2315                     gotoprobe = PL_main_root;
2316                 break;
2317             case CXt_SUB:
2318                 if (CvDEPTH(cx->blk_sub.cv)) {
2319                     gotoprobe = CvROOT(cx->blk_sub.cv);
2320                     break;
2321                 }
2322                 /* FALL THROUGH */
2323             case CXt_FORMAT:
2324             case CXt_NULL:
2325                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2326             default:
2327                 if (ix)
2328                     DIE(aTHX_ "panic: goto");
2329                 gotoprobe = PL_main_root;
2330                 break;
2331             }
2332             if (gotoprobe) {
2333                 retop = dofindlabel(gotoprobe, label,
2334                                     enterops, enterops + GOTO_DEPTH);
2335                 if (retop)
2336                     break;
2337             }
2338             PL_lastgotoprobe = gotoprobe;
2339         }
2340         if (!retop)
2341             DIE(aTHX_ "Can't find label %s", label);
2342
2343         /* if we're leaving an eval, check before we pop any frames
2344            that we're not going to punt, otherwise the error
2345            won't be caught */
2346
2347         if (leaving_eval && *enterops && enterops[1]) {
2348             I32 i;
2349             for (i = 1; enterops[i]; i++)
2350                 if (enterops[i]->op_type == OP_ENTERITER)
2351                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2352         }
2353
2354         /* pop unwanted frames */
2355
2356         if (ix < cxstack_ix) {
2357             I32 oldsave;
2358
2359             if (ix < 0)
2360                 ix = 0;
2361             dounwind(ix);
2362             TOPBLOCK(cx);
2363             oldsave = PL_scopestack[PL_scopestack_ix];
2364             LEAVE_SCOPE(oldsave);
2365         }
2366
2367         /* push wanted frames */
2368
2369         if (*enterops && enterops[1]) {
2370             OP *oldop = PL_op;
2371             for (ix = 1; enterops[ix]; ix++) {
2372                 PL_op = enterops[ix];
2373                 /* Eventually we may want to stack the needed arguments
2374                  * for each op.  For now, we punt on the hard ones. */
2375                 if (PL_op->op_type == OP_ENTERITER)
2376                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2377                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2378             }
2379             PL_op = oldop;
2380         }
2381     }
2382
2383     if (do_dump) {
2384 #ifdef VMS
2385         if (!retop) retop = PL_main_start;
2386 #endif
2387         PL_restartop = retop;
2388         PL_do_undump = TRUE;
2389
2390         my_unexec();
2391
2392         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2393         PL_do_undump = FALSE;
2394     }
2395
2396     RETURNOP(retop);
2397 }
2398
2399 PP(pp_exit)
2400 {
2401     dSP;
2402     I32 anum;
2403
2404     if (MAXARG < 1)
2405         anum = 0;
2406     else {
2407         anum = SvIVx(POPs);
2408 #ifdef VMS
2409         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2410             anum = 0;
2411         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2412 #endif
2413     }
2414     PL_exit_flags |= PERL_EXIT_EXPECTED;
2415     my_exit(anum);
2416     PUSHs(&PL_sv_undef);
2417     RETURN;
2418 }
2419
2420 #ifdef NOTYET
2421 PP(pp_nswitch)
2422 {
2423     dSP;
2424     NV value = SvNVx(GvSV(cCOP->cop_gv));
2425     register I32 match = I_32(value);
2426
2427     if (value < 0.0) {
2428         if (((NV)match) > value)
2429             --match;            /* was fractional--truncate other way */
2430     }
2431     match -= cCOP->uop.scop.scop_offset;
2432     if (match < 0)
2433         match = 0;
2434     else if (match > cCOP->uop.scop.scop_max)
2435         match = cCOP->uop.scop.scop_max;
2436     PL_op = cCOP->uop.scop.scop_next[match];
2437     RETURNOP(PL_op);
2438 }
2439
2440 PP(pp_cswitch)
2441 {
2442     dSP;
2443     register I32 match;
2444
2445     if (PL_multiline)
2446         PL_op = PL_op->op_next;                 /* can't assume anything */
2447     else {
2448         STRLEN n_a;
2449         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2450         match -= cCOP->uop.scop.scop_offset;
2451         if (match < 0)
2452             match = 0;
2453         else if (match > cCOP->uop.scop.scop_max)
2454             match = cCOP->uop.scop.scop_max;
2455         PL_op = cCOP->uop.scop.scop_next[match];
2456     }
2457     RETURNOP(PL_op);
2458 }
2459 #endif
2460
2461 /* Eval. */
2462
2463 STATIC void
2464 S_save_lines(pTHX_ AV *array, SV *sv)
2465 {
2466     register char *s = SvPVX(sv);
2467     register char *send = SvPVX(sv) + SvCUR(sv);
2468     register char *t;
2469     register I32 line = 1;
2470
2471     while (s && s < send) {
2472         SV *tmpstr = NEWSV(85,0);
2473
2474         sv_upgrade(tmpstr, SVt_PVMG);
2475         t = strchr(s, '\n');
2476         if (t)
2477             t++;
2478         else
2479             t = send;
2480
2481         sv_setpvn(tmpstr, s, t - s);
2482         av_store(array, line++, tmpstr);
2483         s = t;
2484     }
2485 }
2486
2487 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2488 STATIC void *
2489 S_docatch_body(pTHX_ va_list args)
2490 {
2491     return docatch_body();
2492 }
2493 #endif
2494
2495 STATIC void *
2496 S_docatch_body(pTHX)
2497 {
2498     CALLRUNOPS(aTHX);
2499     return NULL;
2500 }
2501
2502 STATIC OP *
2503 S_docatch(pTHX_ OP *o)
2504 {
2505     int ret;
2506     OP *oldop = PL_op;
2507     OP *retop;
2508     volatile PERL_SI *cursi = PL_curstackinfo;
2509     dJMPENV;
2510
2511 #ifdef DEBUGGING
2512     assert(CATCH_GET == TRUE);
2513 #endif
2514     PL_op = o;
2515
2516     /* Normally, the leavetry at the end of this block of ops will
2517      * pop an op off the return stack and continue there. By setting
2518      * the op to Nullop, we force an exit from the inner runops()
2519      * loop. DAPM.
2520      */
2521     retop = pop_return();
2522     push_return(Nullop);
2523
2524 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2525  redo_body:
2526     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2527 #else
2528     JMPENV_PUSH(ret);
2529 #endif
2530     switch (ret) {
2531     case 0:
2532 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2533  redo_body:
2534         docatch_body();
2535 #endif
2536         break;
2537     case 3:
2538         /* die caught by an inner eval - continue inner loop */
2539         if (PL_restartop && cursi == PL_curstackinfo) {
2540             PL_op = PL_restartop;
2541             PL_restartop = 0;
2542             goto redo_body;
2543         }
2544         /* a die in this eval - continue in outer loop */
2545         if (!PL_restartop)
2546             break;
2547         /* FALL THROUGH */
2548     default:
2549         JMPENV_POP;
2550         PL_op = oldop;
2551         JMPENV_JUMP(ret);
2552         /* NOTREACHED */
2553     }
2554     JMPENV_POP;
2555     PL_op = oldop;
2556     return retop;
2557 }
2558
2559 OP *
2560 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2561 /* sv Text to convert to OP tree. */
2562 /* startop op_free() this to undo. */
2563 /* code Short string id of the caller. */
2564 {
2565     dSP;                                /* Make POPBLOCK work. */
2566     PERL_CONTEXT *cx;
2567     SV **newsp;
2568     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2569     I32 optype;
2570     OP dummy;
2571     OP *rop;
2572     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2573     char *tmpbuf = tbuf;
2574     char *safestr;
2575     int runtime;
2576     CV* runcv;
2577
2578     ENTER;
2579     lex_start(sv);
2580     SAVETMPS;
2581     /* switch to eval mode */
2582
2583     if (PL_curcop == &PL_compiling) {
2584         SAVECOPSTASH_FREE(&PL_compiling);
2585         CopSTASH_set(&PL_compiling, PL_curstash);
2586     }
2587     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2588         SV *sv = sv_newmortal();
2589         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2590                        code, (unsigned long)++PL_evalseq,
2591                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2592         tmpbuf = SvPVX(sv);
2593     }
2594     else
2595         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2596     SAVECOPFILE_FREE(&PL_compiling);
2597     CopFILE_set(&PL_compiling, tmpbuf+2);
2598     SAVECOPLINE(&PL_compiling);
2599     CopLINE_set(&PL_compiling, 1);
2600     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2601        deleting the eval's FILEGV from the stash before gv_check() runs
2602        (i.e. before run-time proper). To work around the coredump that
2603        ensues, we always turn GvMULTI_on for any globals that were
2604        introduced within evals. See force_ident(). GSAR 96-10-12 */
2605     safestr = savepv(tmpbuf);
2606     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2607     SAVEHINTS();
2608 #ifdef OP_IN_REGISTER
2609     PL_opsave = op;
2610 #else
2611     SAVEVPTR(PL_op);
2612 #endif
2613     PL_hints &= HINT_UTF8;
2614
2615     /* we get here either during compilation, or via pp_regcomp at runtime */
2616     runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2617     if (runtime)
2618         runcv = find_runcv();
2619
2620     PL_op = &dummy;
2621     PL_op->op_type = OP_ENTEREVAL;
2622     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2623     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2624     PUSHEVAL(cx, 0, Nullgv);
2625
2626     if (runtime)
2627         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2628     else
2629         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2630     POPBLOCK(cx,PL_curpm);
2631     POPEVAL(cx);
2632
2633     (*startop)->op_type = OP_NULL;
2634     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2635     lex_end();
2636     /* XXX DAPM do this properly one year */
2637     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2638     LEAVE;
2639     if (PL_curcop == &PL_compiling)
2640         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2641 #ifdef OP_IN_REGISTER
2642     op = PL_opsave;
2643 #endif
2644     return rop;
2645 }
2646
2647
2648 /*
2649 =for apidoc find_runcv
2650
2651 Locate the CV corresponding to the currently executing sub or eval.
2652
2653 =cut
2654 */
2655
2656 CV*
2657 Perl_find_runcv(pTHX)
2658 {
2659     I32          ix;
2660     PERL_SI      *si;
2661     PERL_CONTEXT *cx;
2662
2663     for (si = PL_curstackinfo; si; si = si->si_prev) {
2664         for (ix = si->si_cxix; ix >= 0; ix--) {
2665             cx = &(si->si_cxstack[ix]);
2666             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT)
2667                 return cx->blk_sub.cv;
2668             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2669                 return PL_compcv;
2670         }
2671     }
2672     return PL_main_cv;
2673 }
2674
2675
2676 /* Compile a require/do, an eval '', or a /(?{...})/.
2677  * In the last case, startop is non-null, and contains the address of
2678  * a pointer that should be set to the just-compiled code.
2679  * outside is the lexically enclosing CV (if any) that invoked us.
2680  */
2681
2682 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2683 STATIC OP *
2684 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2685 {
2686     dSP;
2687     OP *saveop = PL_op;
2688
2689     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2690                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2691                   : EVAL_INEVAL);
2692
2693     PUSHMARK(SP);
2694
2695     SAVESPTR(PL_compcv);
2696     PL_compcv = (CV*)NEWSV(1104,0);
2697     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2698     CvEVAL_on(PL_compcv);
2699     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2700     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2701
2702     CvOUTSIDE_SEQ(PL_compcv) = seq;
2703     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2704
2705     /* set up a scratch pad */
2706
2707     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2708
2709
2710     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2711
2712     /* make sure we compile in the right package */
2713
2714     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2715         SAVESPTR(PL_curstash);
2716         PL_curstash = CopSTASH(PL_curcop);
2717     }
2718     SAVESPTR(PL_beginav);
2719     PL_beginav = newAV();
2720     SAVEFREESV(PL_beginav);
2721     SAVEI32(PL_error_count);
2722
2723     /* try to compile it */
2724
2725     PL_eval_root = Nullop;
2726     PL_error_count = 0;
2727     PL_curcop = &PL_compiling;
2728     PL_curcop->cop_arybase = 0;
2729     if (saveop && saveop->op_flags & OPf_SPECIAL)
2730         PL_in_eval |= EVAL_KEEPERR;
2731     else
2732         sv_setpv(ERRSV,"");
2733     if (yyparse() || PL_error_count || !PL_eval_root) {
2734         SV **newsp;
2735         I32 gimme;
2736         PERL_CONTEXT *cx;
2737         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2738         STRLEN n_a;
2739
2740         PL_op = saveop;
2741         if (PL_eval_root) {
2742             op_free(PL_eval_root);
2743             PL_eval_root = Nullop;
2744         }
2745         SP = PL_stack_base + POPMARK;           /* pop original mark */
2746         if (!startop) {
2747             POPBLOCK(cx,PL_curpm);
2748             POPEVAL(cx);
2749             pop_return();
2750         }
2751         lex_end();
2752         LEAVE;
2753         if (optype == OP_REQUIRE) {
2754             char* msg = SvPVx(ERRSV, n_a);
2755             DIE(aTHX_ "%sCompilation failed in require",
2756                 *msg ? msg : "Unknown error\n");
2757         }
2758         else if (startop) {
2759             char* msg = SvPVx(ERRSV, n_a);
2760
2761             POPBLOCK(cx,PL_curpm);
2762             POPEVAL(cx);
2763             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2764                        (*msg ? msg : "Unknown error\n"));
2765         }
2766         else {
2767             char* msg = SvPVx(ERRSV, n_a);
2768             if (!*msg) {
2769                 sv_setpv(ERRSV, "Compilation error");
2770             }
2771         }
2772         RETPUSHUNDEF;
2773     }
2774     CopLINE_set(&PL_compiling, 0);
2775     if (startop) {
2776         *startop = PL_eval_root;
2777     } else
2778         SAVEFREEOP(PL_eval_root);
2779     if (gimme & G_VOID)
2780         scalarvoid(PL_eval_root);
2781     else if (gimme & G_ARRAY)
2782         list(PL_eval_root);
2783     else
2784         scalar(PL_eval_root);
2785
2786     DEBUG_x(dump_eval());
2787
2788     /* Register with debugger: */
2789     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2790         CV *cv = get_cv("DB::postponed", FALSE);
2791         if (cv) {
2792             dSP;
2793             PUSHMARK(SP);
2794             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2795             PUTBACK;
2796             call_sv((SV*)cv, G_DISCARD);
2797         }
2798     }
2799
2800     /* compiled okay, so do it */
2801
2802     CvDEPTH(PL_compcv) = 1;
2803     SP = PL_stack_base + POPMARK;               /* pop original mark */
2804     PL_op = saveop;                     /* The caller may need it. */
2805     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2806
2807     RETURNOP(PL_eval_start);
2808 }
2809
2810 STATIC PerlIO *
2811 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2812 {
2813     STRLEN namelen = strlen(name);
2814     PerlIO *fp;
2815
2816     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2817         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2818         char *pmc = SvPV_nolen(pmcsv);
2819         Stat_t pmstat;
2820         Stat_t pmcstat;
2821         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2822             fp = PerlIO_open(name, mode);
2823         }
2824         else {
2825             if (PerlLIO_stat(name, &pmstat) < 0 ||
2826                 pmstat.st_mtime < pmcstat.st_mtime)
2827             {
2828                 fp = PerlIO_open(pmc, mode);
2829             }
2830             else {
2831                 fp = PerlIO_open(name, mode);
2832             }
2833         }
2834         SvREFCNT_dec(pmcsv);
2835     }
2836     else {
2837         fp = PerlIO_open(name, mode);
2838     }
2839     return fp;
2840 }
2841
2842 PP(pp_require)
2843 {
2844     dSP;
2845     register PERL_CONTEXT *cx;
2846     SV *sv;
2847     char *name;
2848     STRLEN len;
2849     char *tryname = Nullch;
2850     SV *namesv = Nullsv;
2851     SV** svp;
2852     I32 gimme = GIMME_V;
2853     PerlIO *tryrsfp = 0;
2854     STRLEN n_a;
2855     int filter_has_file = 0;
2856     GV *filter_child_proc = 0;
2857     SV *filter_state = 0;
2858     SV *filter_sub = 0;
2859     SV *hook_sv = 0;
2860     SV *encoding;
2861     OP *op;
2862
2863     sv = POPs;
2864     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2865         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2866             UV rev = 0, ver = 0, sver = 0;
2867             STRLEN len;
2868             U8 *s = (U8*)SvPVX(sv);
2869             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2870             if (s < end) {
2871                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2872                 s += len;
2873                 if (s < end) {
2874                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
2875                     s += len;
2876                     if (s < end)
2877                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
2878                 }
2879             }
2880             if (PERL_REVISION < rev
2881                 || (PERL_REVISION == rev
2882                     && (PERL_VERSION < ver
2883                         || (PERL_VERSION == ver
2884                             && PERL_SUBVERSION < sver))))
2885             {
2886                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2887                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2888                     PERL_VERSION, PERL_SUBVERSION);
2889             }
2890             if (ckWARN(WARN_PORTABLE))
2891                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2892                         "v-string in use/require non-portable");
2893             RETPUSHYES;
2894         }
2895         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
2896             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2897                 + ((NV)PERL_SUBVERSION/(NV)1000000)
2898                 + 0.00000099 < SvNV(sv))
2899             {
2900                 NV nrev = SvNV(sv);
2901                 UV rev = (UV)nrev;
2902                 NV nver = (nrev - rev) * 1000;
2903                 UV ver = (UV)(nver + 0.0009);
2904                 NV nsver = (nver - ver) * 1000;
2905                 UV sver = (UV)(nsver + 0.0009);
2906
2907                 /* help out with the "use 5.6" confusion */
2908                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2909                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2910                         " (did you mean v%"UVuf".%03"UVuf"?)--"
2911                         "this is only v%d.%d.%d, stopped",
2912                         rev, ver, sver, rev, ver/100,
2913                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2914                 }
2915                 else {
2916                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2917                         "this is only v%d.%d.%d, stopped",
2918                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
2919                         PERL_SUBVERSION);
2920                 }
2921             }
2922             RETPUSHYES;
2923         }
2924     }
2925     name = SvPV(sv, len);
2926     if (!(name && len > 0 && *name))
2927         DIE(aTHX_ "Null filename used");
2928     TAINT_PROPER("require");
2929     if (PL_op->op_type == OP_REQUIRE &&
2930       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2931       *svp != &PL_sv_undef)
2932         RETPUSHYES;
2933
2934     /* prepare to compile file */
2935
2936     if (path_is_absolute(name)) {
2937         tryname = name;
2938         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2939     }
2940 #ifdef MACOS_TRADITIONAL
2941     if (!tryrsfp) {
2942         char newname[256];
2943
2944         MacPerl_CanonDir(name, newname, 1);
2945         if (path_is_absolute(newname)) {
2946             tryname = newname;
2947             tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2948         }
2949     }
2950 #endif
2951     if (!tryrsfp) {
2952         AV *ar = GvAVn(PL_incgv);
2953         I32 i;
2954 #ifdef VMS
2955         char *unixname;
2956         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2957 #endif
2958         {
2959             namesv = NEWSV(806, 0);
2960             for (i = 0; i <= AvFILL(ar); i++) {
2961                 SV *dirsv = *av_fetch(ar, i, TRUE);
2962
2963                 if (SvROK(dirsv)) {
2964                     int count;
2965                     SV *loader = dirsv;
2966
2967                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
2968                         && !sv_isobject(loader))
2969                     {
2970                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2971                     }
2972
2973                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2974                                    PTR2UV(SvRV(dirsv)), name);
2975                     tryname = SvPVX(namesv);
2976                     tryrsfp = 0;
2977
2978                     ENTER;
2979                     SAVETMPS;
2980                     EXTEND(SP, 2);
2981
2982                     PUSHMARK(SP);
2983                     PUSHs(dirsv);
2984                     PUSHs(sv);
2985                     PUTBACK;
2986                     if (sv_isobject(loader))
2987                         count = call_method("INC", G_ARRAY);
2988                     else
2989                         count = call_sv(loader, G_ARRAY);
2990                     SPAGAIN;
2991
2992                     if (count > 0) {
2993                         int i = 0;
2994                         SV *arg;
2995
2996                         SP -= count - 1;
2997                         arg = SP[i++];
2998
2999                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3000                             arg = SvRV(arg);
3001                         }
3002
3003                         if (SvTYPE(arg) == SVt_PVGV) {
3004                             IO *io = GvIO((GV *)arg);
3005
3006                             ++filter_has_file;
3007
3008                             if (io) {
3009                                 tryrsfp = IoIFP(io);
3010                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3011                                     /* reading from a child process doesn't
3012                                        nest -- when returning from reading
3013                                        the inner module, the outer one is
3014                                        unreadable (closed?)  I've tried to
3015                                        save the gv to manage the lifespan of
3016                                        the pipe, but this didn't help. XXX */
3017                                     filter_child_proc = (GV *)arg;
3018                                     (void)SvREFCNT_inc(filter_child_proc);
3019                                 }
3020                                 else {
3021                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3022                                         PerlIO_close(IoOFP(io));
3023                                     }
3024                                     IoIFP(io) = Nullfp;
3025                                     IoOFP(io) = Nullfp;
3026                                 }
3027                             }
3028
3029                             if (i < count) {
3030                                 arg = SP[i++];
3031                             }
3032                         }
3033
3034                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3035                             filter_sub = arg;
3036                             (void)SvREFCNT_inc(filter_sub);
3037
3038                             if (i < count) {
3039                                 filter_state = SP[i];
3040                                 (void)SvREFCNT_inc(filter_state);
3041                             }
3042
3043                             if (tryrsfp == 0) {
3044                                 tryrsfp = PerlIO_open("/dev/null",
3045                                                       PERL_SCRIPT_MODE);
3046                             }
3047                         }
3048                     }
3049
3050                     PUTBACK;
3051                     FREETMPS;
3052                     LEAVE;
3053
3054                     if (tryrsfp) {
3055                         hook_sv = dirsv;
3056                         break;
3057                     }
3058
3059                     filter_has_file = 0;
3060                     if (filter_child_proc) {
3061                         SvREFCNT_dec(filter_child_proc);
3062                         filter_child_proc = 0;
3063                     }
3064                     if (filter_state) {
3065                         SvREFCNT_dec(filter_state);
3066                         filter_state = 0;
3067                     }
3068                     if (filter_sub) {
3069                         SvREFCNT_dec(filter_sub);
3070                         filter_sub = 0;
3071                     }
3072                 }
3073                 else {
3074                   if (!path_is_absolute(name)
3075 #ifdef MACOS_TRADITIONAL
3076                         /* We consider paths of the form :a:b ambiguous and interpret them first
3077                            as global then as local
3078                         */
3079                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3080 #endif
3081                   ) {
3082                     char *dir = SvPVx(dirsv, n_a);
3083 #ifdef MACOS_TRADITIONAL
3084                     char buf1[256];
3085                     char buf2[256];
3086
3087                     MacPerl_CanonDir(name, buf2, 1);
3088                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3089 #else
3090 #ifdef VMS
3091                     char *unixdir;
3092                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3093                         continue;
3094                     sv_setpv(namesv, unixdir);
3095                     sv_catpv(namesv, unixname);
3096 #else
3097                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3098 #endif
3099 #endif
3100                     TAINT_PROPER("require");
3101                     tryname = SvPVX(namesv);
3102                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3103                     if (tryrsfp) {
3104                         if (tryname[0] == '.' && tryname[1] == '/')
3105                             tryname += 2;
3106                         break;
3107                     }
3108                   }
3109                 }
3110             }
3111         }
3112     }
3113     SAVECOPFILE_FREE(&PL_compiling);
3114     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3115     SvREFCNT_dec(namesv);
3116     if (!tryrsfp) {
3117         if (PL_op->op_type == OP_REQUIRE) {
3118             char *msgstr = name;
3119             if (namesv) {                       /* did we lookup @INC? */
3120                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3121                 SV *dirmsgsv = NEWSV(0, 0);
3122                 AV *ar = GvAVn(PL_incgv);
3123                 I32 i;
3124                 sv_catpvn(msg, " in @INC", 8);
3125                 if (instr(SvPVX(msg), ".h "))
3126                     sv_catpv(msg, " (change .h to .ph maybe?)");
3127                 if (instr(SvPVX(msg), ".ph "))
3128                     sv_catpv(msg, " (did you run h2ph?)");
3129                 sv_catpv(msg, " (@INC contains:");
3130                 for (i = 0; i <= AvFILL(ar); i++) {
3131                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3132                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3133                     sv_catsv(msg, dirmsgsv);
3134                 }
3135                 sv_catpvn(msg, ")", 1);
3136                 SvREFCNT_dec(dirmsgsv);
3137                 msgstr = SvPV_nolen(msg);
3138             }
3139             DIE(aTHX_ "Can't locate %s", msgstr);
3140         }
3141
3142         RETPUSHUNDEF;
3143     }
3144     else
3145         SETERRNO(0, SS_NORMAL);
3146
3147     /* Assume success here to prevent recursive requirement. */
3148     len = strlen(name);
3149     /* Check whether a hook in @INC has already filled %INC */
3150     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3151         (void)hv_store(GvHVn(PL_incgv), name, len,
3152                        (hook_sv ? SvREFCNT_inc(hook_sv)
3153                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3154                        0 );
3155     }
3156
3157     ENTER;
3158     SAVETMPS;
3159     lex_start(sv_2mortal(newSVpvn("",0)));
3160     SAVEGENERICSV(PL_rsfp_filters);
3161     PL_rsfp_filters = Nullav;
3162
3163     PL_rsfp = tryrsfp;
3164     SAVEHINTS();
3165     PL_hints = 0;
3166     SAVESPTR(PL_compiling.cop_warnings);
3167     if (PL_dowarn & G_WARN_ALL_ON)
3168         PL_compiling.cop_warnings = pWARN_ALL ;
3169     else if (PL_dowarn & G_WARN_ALL_OFF)
3170         PL_compiling.cop_warnings = pWARN_NONE ;
3171     else if (PL_taint_warn)
3172         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3173     else
3174         PL_compiling.cop_warnings = pWARN_STD ;
3175     SAVESPTR(PL_compiling.cop_io);
3176     PL_compiling.cop_io = Nullsv;
3177
3178     if (filter_sub || filter_child_proc) {
3179         SV *datasv = filter_add(run_user_filter, Nullsv);
3180         IoLINES(datasv) = filter_has_file;
3181         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3182         IoTOP_GV(datasv) = (GV *)filter_state;
3183         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3184     }
3185
3186     /* switch to eval mode */
3187     push_return(PL_op->op_next);
3188     PUSHBLOCK(cx, CXt_EVAL, SP);
3189     PUSHEVAL(cx, name, Nullgv);
3190
3191     SAVECOPLINE(&PL_compiling);
3192     CopLINE_set(&PL_compiling, 0);
3193
3194     PUTBACK;
3195
3196     /* Store and reset encoding. */
3197     encoding = PL_encoding;
3198     PL_encoding = Nullsv;
3199
3200     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3201
3202     /* Restore encoding. */
3203     PL_encoding = encoding;
3204
3205     return op;
3206 }
3207
3208 PP(pp_dofile)
3209 {
3210     return pp_require();
3211 }
3212
3213 PP(pp_entereval)
3214 {
3215     dSP;
3216     register PERL_CONTEXT *cx;
3217     dPOPss;
3218     I32 gimme = GIMME_V, was = PL_sub_generation;
3219     char tbuf[TYPE_DIGITS(long) + 12];
3220     char *tmpbuf = tbuf;
3221     char *safestr;
3222     STRLEN len;
3223     OP *ret;
3224     CV* runcv;
3225
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     runcv = find_runcv();
3273
3274     push_return(PL_op->op_next);
3275     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3276     PUSHEVAL(cx, 0, Nullgv);
3277
3278     /* prepare to compile string */
3279
3280     if (PERLDB_LINE && PL_curstash != PL_debstash)
3281         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3282     PUTBACK;
3283     ret = doeval(gimme, NULL, runcv, PL_curcop->cop_seq);
3284     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3285         && ret != PL_op->op_next) {     /* Successive compilation. */
3286         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3287     }
3288     return DOCATCH(ret);
3289 }
3290
3291 PP(pp_leaveeval)
3292 {
3293     dSP;
3294     register SV **mark;
3295     SV **newsp;
3296     PMOP *newpm;
3297     I32 gimme;
3298     register PERL_CONTEXT *cx;
3299     OP *retop;
3300     U8 save_flags = PL_op -> op_flags;
3301     I32 optype;
3302
3303     POPBLOCK(cx,newpm);
3304     POPEVAL(cx);
3305     retop = pop_return();
3306
3307     TAINT_NOT;
3308     if (gimme == G_VOID)
3309         MARK = newsp;
3310     else if (gimme == G_SCALAR) {
3311         MARK = newsp + 1;
3312         if (MARK <= SP) {
3313             if (SvFLAGS(TOPs) & SVs_TEMP)
3314                 *MARK = TOPs;
3315             else
3316                 *MARK = sv_mortalcopy(TOPs);
3317         }
3318         else {
3319             MEXTEND(mark,0);
3320             *MARK = &PL_sv_undef;
3321         }
3322         SP = MARK;
3323     }
3324     else {
3325         /* in case LEAVE wipes old return values */
3326         for (mark = newsp + 1; mark <= SP; mark++) {
3327             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3328                 *mark = sv_mortalcopy(*mark);
3329                 TAINT_NOT;      /* Each item is independent */
3330             }
3331         }
3332     }
3333     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3334
3335 #ifdef DEBUGGING
3336     assert(CvDEPTH(PL_compcv) == 1);
3337 #endif
3338     CvDEPTH(PL_compcv) = 0;
3339     lex_end();
3340
3341     if (optype == OP_REQUIRE &&
3342         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3343     {
3344         /* Unassume the success we assumed earlier. */
3345         SV *nsv = cx->blk_eval.old_namesv;
3346         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3347         retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3348         /* die_where() did LEAVE, or we won't be here */
3349     }
3350     else {
3351         LEAVE;
3352         if (!(save_flags & OPf_SPECIAL))
3353             sv_setpv(ERRSV,"");
3354     }
3355
3356     RETURNOP(retop);
3357 }
3358
3359 PP(pp_entertry)
3360 {
3361     dSP;
3362     register PERL_CONTEXT *cx;
3363     I32 gimme = GIMME_V;
3364
3365     ENTER;
3366     SAVETMPS;
3367
3368     push_return(cLOGOP->op_other->op_next);
3369     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3370     PUSHEVAL(cx, 0, 0);
3371
3372     PL_in_eval = EVAL_INEVAL;
3373     sv_setpv(ERRSV,"");
3374     PUTBACK;
3375     return DOCATCH(PL_op->op_next);
3376 }
3377
3378 PP(pp_leavetry)
3379 {
3380     dSP;
3381     register SV **mark;
3382     SV **newsp;
3383     PMOP *newpm;
3384     OP* retop;
3385     I32 gimme;
3386     register PERL_CONTEXT *cx;
3387     I32 optype;
3388
3389     POPBLOCK(cx,newpm);
3390     POPEVAL(cx);
3391     retop = pop_return();
3392
3393     TAINT_NOT;
3394     if (gimme == G_VOID)
3395         SP = newsp;
3396     else if (gimme == G_SCALAR) {
3397         MARK = newsp + 1;
3398         if (MARK <= SP) {
3399             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3400                 *MARK = TOPs;
3401             else
3402                 *MARK = sv_mortalcopy(TOPs);
3403         }
3404         else {
3405             MEXTEND(mark,0);
3406             *MARK = &PL_sv_undef;
3407         }
3408         SP = MARK;
3409     }
3410     else {
3411         /* in case LEAVE wipes old return values */
3412         for (mark = newsp + 1; mark <= SP; mark++) {
3413             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3414                 *mark = sv_mortalcopy(*mark);
3415                 TAINT_NOT;      /* Each item is independent */
3416             }
3417         }
3418     }
3419     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3420
3421     LEAVE;
3422     sv_setpv(ERRSV,"");
3423     RETURNOP(retop);
3424 }
3425
3426 STATIC void
3427 S_doparseform(pTHX_ SV *sv)
3428 {
3429     STRLEN len;
3430     register char *s = SvPV_force(sv, len);
3431     register char *send = s + len;
3432     register char *base = Nullch;
3433     register I32 skipspaces = 0;
3434     bool noblank   = FALSE;
3435     bool repeat    = FALSE;
3436     bool postspace = FALSE;
3437     U16 *fops;
3438     register U16 *fpc;
3439     U16 *linepc = 0;
3440     register I32 arg;
3441     bool ischop;
3442
3443     if (len == 0)
3444         Perl_croak(aTHX_ "Null picture in formline");
3445
3446     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3447     fpc = fops;
3448
3449     if (s < send) {
3450         linepc = fpc;
3451         *fpc++ = FF_LINEMARK;
3452         noblank = repeat = FALSE;
3453         base = s;
3454     }
3455
3456     while (s <= send) {
3457         switch (*s++) {
3458         default:
3459             skipspaces = 0;
3460             continue;
3461
3462         case '~':
3463             if (*s == '~') {
3464                 repeat = TRUE;
3465                 *s = ' ';
3466             }
3467             noblank = TRUE;
3468             s[-1] = ' ';
3469             /* FALL THROUGH */
3470         case ' ': case '\t':
3471             skipspaces++;
3472             continue;
3473
3474         case '\n': case 0:
3475             arg = s - base;
3476             skipspaces++;
3477             arg -= skipspaces;
3478             if (arg) {
3479                 if (postspace)
3480                     *fpc++ = FF_SPACE;
3481                 *fpc++ = FF_LITERAL;
3482                 *fpc++ = (U16)arg;
3483             }
3484             postspace = FALSE;
3485             if (s <= send)
3486                 skipspaces--;
3487             if (skipspaces) {
3488                 *fpc++ = FF_SKIP;
3489                 *fpc++ = (U16)skipspaces;
3490             }
3491             skipspaces = 0;
3492             if (s <= send)
3493                 *fpc++ = FF_NEWLINE;
3494             if (noblank) {
3495                 *fpc++ = FF_BLANK;
3496                 if (repeat)
3497                     arg = fpc - linepc + 1;
3498                 else
3499                     arg = 0;
3500                 *fpc++ = (U16)arg;
3501             }
3502             if (s < send) {
3503                 linepc = fpc;
3504                 *fpc++ = FF_LINEMARK;
3505                 noblank = repeat = FALSE;
3506                 base = s;
3507             }
3508             else
3509                 s++;
3510             continue;
3511
3512         case '@':
3513         case '^':
3514             ischop = s[-1] == '^';
3515
3516             if (postspace) {
3517                 *fpc++ = FF_SPACE;
3518                 postspace = FALSE;
3519             }
3520             arg = (s - base) - 1;
3521             if (arg) {
3522                 *fpc++ = FF_LITERAL;
3523                 *fpc++ = (U16)arg;
3524             }
3525
3526             base = s - 1;
3527             *fpc++ = FF_FETCH;
3528             if (*s == '*') {
3529                 s++;
3530                 *fpc++ = 0;
3531                 *fpc++ = FF_LINEGLOB;
3532             }
3533             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3534                 arg = ischop ? 512 : 0;
3535                 base = s - 1;
3536                 while (*s == '#')
3537                     s++;
3538                 if (*s == '.') {
3539                     char *f;
3540                     s++;
3541                     f = s;
3542                     while (*s == '#')
3543                         s++;
3544                     arg |= 256 + (s - f);
3545                 }
3546                 *fpc++ = s - base;              /* fieldsize for FETCH */
3547                 *fpc++ = FF_DECIMAL;
3548                 *fpc++ = (U16)arg;
3549             }
3550             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3551                 arg = ischop ? 512 : 0;
3552                 base = s - 1;
3553                 s++;                                /* skip the '0' first */
3554                 while (*s == '#')
3555                     s++;
3556                 if (*s == '.') {
3557                     char *f;
3558                     s++;
3559                     f = s;
3560                     while (*s == '#')
3561                         s++;
3562                     arg |= 256 + (s - f);
3563                 }
3564                 *fpc++ = s - base;                /* fieldsize for FETCH */
3565                 *fpc++ = FF_0DECIMAL;
3566                 *fpc++ = (U16)arg;
3567             }
3568             else {
3569                 I32 prespace = 0;
3570                 bool ismore = FALSE;
3571
3572                 if (*s == '>') {
3573                     while (*++s == '>') ;
3574                     prespace = FF_SPACE;
3575                 }
3576                 else if (*s == '|') {
3577                     while (*++s == '|') ;
3578                     prespace = FF_HALFSPACE;
3579                     postspace = TRUE;
3580                 }
3581                 else {
3582                     if (*s == '<')
3583                         while (*++s == '<') ;
3584                     postspace = TRUE;
3585                 }
3586                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3587                     s += 3;
3588                     ismore = TRUE;
3589                 }
3590                 *fpc++ = s - base;              /* fieldsize for FETCH */
3591
3592                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3593
3594                 if (prespace)
3595                     *fpc++ = (U16)prespace;
3596                 *fpc++ = FF_ITEM;
3597                 if (ismore)
3598                     *fpc++ = FF_MORE;
3599                 if (ischop)
3600                     *fpc++ = FF_CHOP;
3601             }
3602             base = s;
3603             skipspaces = 0;
3604             continue;
3605         }
3606     }
3607     *fpc++ = FF_END;
3608
3609     arg = fpc - fops;
3610     { /* need to jump to the next word */
3611         int z;
3612         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3613         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3614         s = SvPVX(sv) + SvCUR(sv) + z;
3615     }
3616     Copy(fops, s, arg, U16);
3617     Safefree(fops);
3618     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3619     SvCOMPILED_on(sv);
3620 }
3621
3622 static I32
3623 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3624 {
3625     SV *datasv = FILTER_DATA(idx);
3626     int filter_has_file = IoLINES(datasv);
3627     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3628     SV *filter_state = (SV *)IoTOP_GV(datasv);
3629     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3630     int len = 0;
3631
3632     /* I was having segfault trouble under Linux 2.2.5 after a
3633        parse error occured.  (Had to hack around it with a test
3634        for PL_error_count == 0.)  Solaris doesn't segfault --
3635        not sure where the trouble is yet.  XXX */
3636
3637     if (filter_has_file) {
3638         len = FILTER_READ(idx+1, buf_sv, maxlen);
3639     }
3640
3641     if (filter_sub && len >= 0) {
3642         dSP;
3643         int count;
3644
3645         ENTER;
3646         SAVE_DEFSV;
3647         SAVETMPS;
3648         EXTEND(SP, 2);
3649
3650         DEFSV = buf_sv;
3651         PUSHMARK(SP);
3652         PUSHs(sv_2mortal(newSViv(maxlen)));
3653         if (filter_state) {
3654             PUSHs(filter_state);
3655         }
3656         PUTBACK;
3657         count = call_sv(filter_sub, G_SCALAR);
3658         SPAGAIN;
3659
3660         if (count > 0) {
3661             SV *out = POPs;
3662             if (SvOK(out)) {
3663                 len = SvIV(out);
3664             }
3665         }
3666
3667         PUTBACK;
3668         FREETMPS;
3669         LEAVE;
3670     }
3671
3672     if (len <= 0) {
3673         IoLINES(datasv) = 0;
3674         if (filter_child_proc) {
3675             SvREFCNT_dec(filter_child_proc);
3676             IoFMT_GV(datasv) = Nullgv;
3677         }
3678         if (filter_state) {
3679             SvREFCNT_dec(filter_state);
3680             IoTOP_GV(datasv) = Nullgv;
3681         }
3682         if (filter_sub) {
3683             SvREFCNT_dec(filter_sub);
3684             IoBOTTOM_GV(datasv) = Nullgv;
3685         }
3686         filter_del(run_user_filter);
3687     }
3688
3689     return len;
3690 }
3691
3692 /* perhaps someone can come up with a better name for
3693    this?  it is not really "absolute", per se ... */
3694 static bool
3695 S_path_is_absolute(pTHX_ char *name)
3696 {
3697     if (PERL_FILE_IS_ABSOLUTE(name)
3698 #ifdef MACOS_TRADITIONAL
3699         || (*name == ':'))
3700 #else
3701         || (*name == '.' && (name[1] == '/' ||
3702                              (name[1] == '.' && name[2] == '/'))))
3703 #endif
3704     {
3705         return TRUE;
3706     }
3707     else
3708         return FALSE;
3709 }