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