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