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