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