pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (c) 1991-2002, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * Now far ahead the Road has gone,
  12  * And I must follow, if I can,
  13  * Pursuing it with eager feet,
  14  * Until it joins some larger way
  15  * Where many paths and errands meet.
  16  * And whither then?  I cannot say.
  17  */
  18
  19 #include "EXTERN.h"
  20 #define PERL_IN_PP_CTL_C
  21 #include "perl.h"
  22
  23 #ifndef WORD_ALIGN
  24 #define WORD_ALIGN sizeof(U16)
  25 #endif
  26
  27 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  28
  29 static I32 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen);
  30
  31 PP(pp_wantarray)
  32 {
  33     dSP;
  34     I32 cxix;
  35     EXTEND(SP, 1);
  36
  37     cxix = dopoptosub(cxstack_ix);
  38     if (cxix < 0)
  39         RETPUSHUNDEF;
  40
  41     switch (cxstack[cxix].blk_gimme) {
  42     case G_ARRAY:
  43         RETPUSHYES;
  44     case G_SCALAR:
  45         RETPUSHNO;
  46     default:
  47         RETPUSHUNDEF;
  48     }
  49 }
  50
  51 PP(pp_regcmaybe)
  52 {
  53     return NORMAL;
  54 }
  55
  56 PP(pp_regcreset)
  57 {
  58     /* XXXX Should store the old value to allow for tie/overload - and
  59        restore in regcomp, where marked with XXXX. */
  60     PL_reginterp_cnt = 0;
  61     return NORMAL;
  62 }
  63
  64 PP(pp_regcomp)
  65 {
  66     dSP;
  67     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  68     register char *t;
  69     SV *tmpstr;
  70     STRLEN len;
  71     MAGIC *mg = Null(MAGIC*);
  72
  73     tmpstr = POPs;
  74
  75     /* prevent recompiling under /o and ithreads. */
  76 #if defined(USE_ITHREADS)
  77     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
  78          RETURN;
  79 #endif
  80
  81     if (SvROK(tmpstr)) {
  82         SV *sv = SvRV(tmpstr);
  83         if(SvMAGICAL(sv))
  84             mg = mg_find(sv, PERL_MAGIC_qr);
  85     }
  86     if (mg) {
  87         regexp *re = (regexp *)mg->mg_obj;
  88         ReREFCNT_dec(PM_GETRE(pm));
  89         PM_SETRE(pm, ReREFCNT_inc(re));
  90     }
  91     else {
  92         t = SvPV(tmpstr, len);
  93
  94         /* Check against the last compiled regexp. */
  95         if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
  96             PM_GETRE(pm)->prelen != (I32)len ||
  97             memNE(PM_GETRE(pm)->precomp, t, len))
  98         {
  99             if (PM_GETRE(pm)) {
 100                 ReREFCNT_dec(PM_GETRE(pm));
 101                 PM_SETRE(pm, Null(REGEXP*));    /* crucial if regcomp aborts */
 102             }
 103             if (PL_op->op_flags & OPf_SPECIAL)
 104                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 105
 106             pm->op_pmflags = pm->op_pmpermflags;        /* reset case sensitivity */
 107             if (DO_UTF8(tmpstr))
 108                 pm->op_pmdynflags |= PMdf_DYN_UTF8;
 109             else {
 110                 pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
 111                 if (pm->op_pmdynflags & PMdf_UTF8)
 112                     t = (char*)bytes_to_utf8((U8*)t, &len);
 113             }
 114             PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
 115             if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
 116                 Safefree(t);
 117             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
 118                                            inside tie/overload accessors.  */
 119         }
 120     }
 121
 122 #ifndef INCOMPLETE_TAINTS
 123     if (PL_tainting) {
 124         if (PL_tainted)
 125             pm->op_pmdynflags |= PMdf_TAINTED;
 126         else
 127             pm->op_pmdynflags &= ~PMdf_TAINTED;
 128     }
 129 #endif
 130
 131     if (!PM_GETRE(pm)->prelen && PL_curpm)
 132         pm = PL_curpm;
 133     else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
 134         pm->op_pmflags |= PMf_WHITE;
 135     else
 136         pm->op_pmflags &= ~PMf_WHITE;
 137
 138     /* XXX runtime compiled output needs to move to the pad */
 139     if (pm->op_pmflags & PMf_KEEP) {
 140         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 141 #if !defined(USE_ITHREADS)
 142         /* XXX can't change the optree at runtime either */
 143         cLOGOP->op_first->op_next = PL_op->op_next;
 144 #endif
 145     }
 146     RETURN;
 147 }
 148
 149 PP(pp_substcont)
 150 {
 151     dSP;
 152     register PMOP *pm = (PMOP*) cLOGOP->op_other;
 153     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 154     register SV *dstr = cx->sb_dstr;
 155     register char *s = cx->sb_s;
 156     register char *m = cx->sb_m;
 157     char *orig = cx->sb_orig;
 158     register REGEXP *rx = cx->sb_rx;
 159
 160     rxres_restore(&cx->sb_rxres, rx);
 161     PL_reg_match_utf8 = SvUTF8(cx->sb_targ) ? 1 : 0;
 162
 163     if (cx->sb_iters++) {
 164         I32 saviters = cx->sb_iters;
 165         if (cx->sb_iters > cx->sb_maxiters)
 166             DIE(aTHX_ "Substitution loop");
 167
 168         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 169             cx->sb_rxtainted |= 2;
 170         sv_catsv(dstr, POPs);
 171
 172         /* Are we done */
 173         if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig,
 174                                      s == m, cx->sb_targ, NULL,
 175                                      ((cx->sb_rflags & REXEC_COPY_STR)
 176                                       ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 177                                       : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 178         {
 179             SV *targ = cx->sb_targ;
 180
 181             sv_catpvn(dstr, s, cx->sb_strend - s);
 182             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 183
 184             (void)SvOOK_off(targ);
 185             Safefree(SvPVX(targ));
 186             SvPVX(targ) = SvPVX(dstr);
 187             SvCUR_set(targ, SvCUR(dstr));
 188             SvLEN_set(targ, SvLEN(dstr));
 189             if (DO_UTF8(dstr))
 190                 SvUTF8_on(targ);
 191             SvPVX(dstr) = 0;
 192             sv_free(dstr);
 193
 194             TAINT_IF(cx->sb_rxtainted & 1);
 195             PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
 196
 197             (void)SvPOK_only_UTF8(targ);
 198             TAINT_IF(cx->sb_rxtainted);
 199             SvSETMAGIC(targ);
 200             SvTAINT(targ);
 201
 202             LEAVE_SCOPE(cx->sb_oldsave);
 203             POPSUBST(cx);
 204             RETURNOP(pm->op_next);
 205         }
 206         cx->sb_iters = saviters;
 207     }
 208     if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
 209         m = s;
 210         s = orig;
 211         cx->sb_orig = orig = rx->subbeg;
 212         s = orig + (m - s);
 213         cx->sb_strend = s + (cx->sb_strend - m);
 214     }
 215     cx->sb_m = m = rx->startp[0] + orig;
 216     if (m > s)
 217         sv_catpvn(dstr, s, m-s);
 218     cx->sb_s = rx->endp[0] + orig;
 219     { /* Update the pos() information. */
 220         SV *sv = cx->sb_targ;
 221         MAGIC *mg;
 222         I32 i;
 223         if (SvTYPE(sv) < SVt_PVMG)
 224             (void)SvUPGRADE(sv, SVt_PVMG);
 225         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 226             sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
 227             mg = mg_find(sv, PERL_MAGIC_regex_global);
 228         }
 229         i = m - orig;
 230         if (DO_UTF8(sv))
 231             sv_pos_b2u(sv, &i);
 232         mg->mg_len = i;
 233     }
 234     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 235     rxres_save(&cx->sb_rxres, rx);
 236     RETURNOP(pm->op_pmreplstart);
 237 }
 238
 239 void
 240 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 241 {
 242     UV *p = (UV*)*rsp;
 243     U32 i;
 244
 245     if (!p || p[1] < rx->nparens) {
 246         i = 6 + rx->nparens * 2;
 247         if (!p)
 248             New(501, p, i, UV);
 249         else
 250             Renew(p, i, UV);
 251         *rsp = (void*)p;
 252     }
 253
 254     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : Nullch);
 255     RX_MATCH_COPIED_off(rx);
 256
 257     *p++ = rx->nparens;
 258
 259     *p++ = PTR2UV(rx->subbeg);
 260     *p++ = (UV)rx->sublen;
 261     for (i = 0; i <= rx->nparens; ++i) {
 262         *p++ = (UV)rx->startp[i];
 263         *p++ = (UV)rx->endp[i];
 264     }
 265 }
 266
 267 void
 268 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 269 {
 270     UV *p = (UV*)*rsp;
 271     U32 i;
 272
 273     if (RX_MATCH_COPIED(rx))
 274         Safefree(rx->subbeg);
 275     RX_MATCH_COPIED_set(rx, *p);
 276     *p++ = 0;
 277
 278     rx->nparens = *p++;
 279
 280     rx->subbeg = INT2PTR(char*,*p++);
 281     rx->sublen = (I32)(*p++);
 282     for (i = 0; i <= rx->nparens; ++i) {
 283         rx->startp[i] = (I32)(*p++);
 284         rx->endp[i] = (I32)(*p++);
 285     }
 286 }
 287
 288 void
 289 Perl_rxres_free(pTHX_ void **rsp)
 290 {
 291     UV *p = (UV*)*rsp;
 292
 293     if (p) {
 294         Safefree(INT2PTR(char*,*p));
 295         Safefree(p);
 296         *rsp = Null(void*);
 297     }
 298 }
 299
 300 PP(pp_formline)
 301 {
 302     dSP; dMARK; dORIGMARK;
 303     register SV *tmpForm = *++MARK;
 304     register U16 *fpc;
 305     register char *t;
 306     register char *f;
 307     register char *s;
 308     register char *send;
 309     register I32 arg;
 310     register SV *sv = Nullsv;
 311     char *item = Nullch;
 312     I32 itemsize  = 0;
 313     I32 fieldsize = 0;
 314     I32 lines = 0;
 315     bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
 316     char *chophere = Nullch;
 317     char *linemark = Nullch;
 318     NV value;
 319     bool gotsome = FALSE;
 320     STRLEN len;
 321     STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
 322     bool item_is_utf = FALSE;
 323
 324     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 325         if (SvREADONLY(tmpForm)) {
 326             SvREADONLY_off(tmpForm);
 327             doparseform(tmpForm);
 328             SvREADONLY_on(tmpForm);
 329         }
 330         else
 331             doparseform(tmpForm);
 332     }
 333
 334     SvPV_force(PL_formtarget, len);
 335     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 336     t += len;
 337     f = SvPV(tmpForm, len);
 338     /* need to jump to the next word */
 339     s = f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN;
 340
 341     fpc = (U16*)s;
 342
 343     for (;;) {
 344         DEBUG_f( {
 345             char *name = "???";
 346             arg = -1;
 347             switch (*fpc) {
 348             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 349             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 350             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 351             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 352             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 353
 354             case FF_CHECKNL:    name = "CHECKNL";       break;
 355             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 356             case FF_SPACE:      name = "SPACE";         break;
 357             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 358             case FF_ITEM:       name = "ITEM";          break;
 359             case FF_CHOP:       name = "CHOP";          break;
 360             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 361             case FF_NEWLINE:    name = "NEWLINE";       break;
 362             case FF_MORE:       name = "MORE";          break;
 363             case FF_LINEMARK:   name = "LINEMARK";      break;
 364             case FF_END:        name = "END";           break;
 365             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 366             }
 367             if (arg >= 0)
 368                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 369             else
 370                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 371         } );
 372         switch (*fpc++) {
 373         case FF_LINEMARK:
 374             linemark = t;
 375             lines++;
 376             gotsome = FALSE;
 377             break;
 378
 379         case FF_LITERAL:
 380             arg = *fpc++;
 381             while (arg--)
 382                 *t++ = *f++;
 383             break;
 384
 385         case FF_SKIP:
 386             f += *fpc++;
 387             break;
 388
 389         case FF_FETCH:
 390             arg = *fpc++;
 391             f += arg;
 392             fieldsize = arg;
 393
 394             if (MARK < SP)
 395                 sv = *++MARK;
 396             else {
 397                 sv = &PL_sv_no;
 398                 if (ckWARN(WARN_SYNTAX))
 399                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 400             }
 401             break;
 402
 403         case FF_CHECKNL:
 404             item = s = SvPV(sv, len);
 405             itemsize = len;
 406             if (DO_UTF8(sv)) {
 407                 itemsize = sv_len_utf8(sv);
 408                 if (itemsize != (I32)len) {
 409                     I32 itembytes;
 410                     if (itemsize > fieldsize) {
 411                         itemsize = fieldsize;
 412                         itembytes = itemsize;
 413                         sv_pos_u2b(sv, &itembytes, 0);
 414                     }
 415                     else
 416                         itembytes = len;
 417                     send = chophere = s + itembytes;
 418                     while (s < send) {
 419                         if (*s & ~31)
 420                             gotsome = TRUE;
 421                         else if (*s == '\n')
 422                             break;
 423                         s++;
 424                     }
 425                     item_is_utf = TRUE;
 426                     itemsize = s - item;
 427                     sv_pos_b2u(sv, &itemsize);
 428                     break;
 429                 }
 430             }
 431             item_is_utf = FALSE;
 432             if (itemsize > fieldsize)
 433                 itemsize = fieldsize;
 434             send = chophere = s + itemsize;
 435             while (s < send) {
 436                 if (*s & ~31)
 437                     gotsome = TRUE;
 438                 else if (*s == '\n')
 439                     break;
 440                 s++;
 441             }
 442             itemsize = s - item;
 443             break;
 444
 445         case FF_CHECKCHOP:
 446             item = s = SvPV(sv, len);
 447             itemsize = len;
 448             if (DO_UTF8(sv)) {
 449                 itemsize = sv_len_utf8(sv);
 450                 if (itemsize != (I32)len) {
 451                     I32 itembytes;
 452                     if (itemsize <= fieldsize) {
 453                         send = chophere = s + itemsize;
 454                         while (s < send) {
 455                             if (*s == '\r') {
 456                                 itemsize = s - item;
 457                                 break;
 458                             }
 459                             if (*s++ & ~31)
 460                                 gotsome = TRUE;
 461                         }
 462                     }
 463                     else {
 464                         itemsize = fieldsize;
 465                         itembytes = itemsize;
 466                         sv_pos_u2b(sv, &itembytes, 0);
 467                         send = chophere = s + itembytes;
 468                         while (s < send || (s == send && isSPACE(*s))) {
 469                             if (isSPACE(*s)) {
 470                                 if (chopspace)
 471                                     chophere = s;
 472                                 if (*s == '\r')
 473                                     break;
 474                             }
 475                             else {
 476                                 if (*s & ~31)
 477                                     gotsome = TRUE;
 478                                 if (strchr(PL_chopset, *s))
 479                                     chophere = s + 1;
 480                             }
 481                             s++;
 482                         }
 483                         itemsize = chophere - item;
 484                         sv_pos_b2u(sv, &itemsize);
 485                     }
 486                     item_is_utf = TRUE;
 487                     break;
 488                 }
 489             }
 490             item_is_utf = FALSE;
 491             if (itemsize <= fieldsize) {
 492                 send = chophere = s + itemsize;
 493                 while (s < send) {
 494                     if (*s == '\r') {
 495                         itemsize = s - item;
 496                         break;
 497                     }
 498                     if (*s++ & ~31)
 499                         gotsome = TRUE;
 500                 }
 501             }
 502             else {
 503                 itemsize = fieldsize;
 504                 send = chophere = s + itemsize;
 505                 while (s < send || (s == send && isSPACE(*s))) {
 506                     if (isSPACE(*s)) {
 507                         if (chopspace)
 508                             chophere = s;
 509                         if (*s == '\r')
 510                             break;
 511                     }
 512                     else {
 513                         if (*s & ~31)
 514                             gotsome = TRUE;
 515                         if (strchr(PL_chopset, *s))
 516                             chophere = s + 1;
 517                     }
 518                     s++;
 519                 }
 520                 itemsize = chophere - item;
 521             }
 522             break;
 523
 524         case FF_SPACE:
 525             arg = fieldsize - itemsize;
 526             if (arg) {
 527                 fieldsize -= arg;
 528                 while (arg-- > 0)
 529                     *t++ = ' ';
 530             }
 531             break;
 532
 533         case FF_HALFSPACE:
 534             arg = fieldsize - itemsize;
 535             if (arg) {
 536                 arg /= 2;
 537                 fieldsize -= arg;
 538                 while (arg-- > 0)
 539                     *t++ = ' ';
 540             }
 541             break;
 542
 543         case FF_ITEM:
 544             arg = itemsize;
 545             s = item;
 546             if (item_is_utf) {
 547                 while (arg--) {
 548                     if (UTF8_IS_CONTINUED(*s)) {
 549                         STRLEN skip = UTF8SKIP(s);
 550                         switch (skip) {
 551                         default:
 552                             Move(s,t,skip,char);
 553                             s += skip;
 554                             t += skip;
 555                             break;
 556                         case 7: *t++ = *s++;
 557                         case 6: *t++ = *s++;
 558                         case 5: *t++ = *s++;
 559                         case 4: *t++ = *s++;
 560                         case 3: *t++ = *s++;
 561                         case 2: *t++ = *s++;
 562                         case 1: *t++ = *s++;
 563                         }
 564                     }
 565                     else {
 566                         if ( !((*t++ = *s++) & ~31) )
 567                             t[-1] = ' ';
 568                     }
 569                 }
 570                 break;
 571             }
 572             while (arg--) {
 573 #ifdef EBCDIC
 574                 int ch = *t++ = *s++;
 575                 if (iscntrl(ch))
 576 #else
 577                 if ( !((*t++ = *s++) & ~31) )
 578 #endif
 579                     t[-1] = ' ';
 580             }
 581             break;
 582
 583         case FF_CHOP:
 584             s = chophere;
 585             if (chopspace) {
 586                 while (*s && isSPACE(*s))
 587                     s++;
 588             }
 589             sv_chop(sv,s);
 590             break;
 591
 592         case FF_LINEGLOB:
 593             item = s = SvPV(sv, len);
 594             itemsize = len;
 595             item_is_utf = FALSE;                /* XXX is this correct? */
 596             if (itemsize) {
 597                 gotsome = TRUE;
 598                 send = s + itemsize;
 599                 while (s < send) {
 600                     if (*s++ == '\n') {
 601                         if (s == send)
 602                             itemsize--;
 603                         else
 604                             lines++;
 605                     }
 606                 }
 607                 SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 608                 sv_catpvn(PL_formtarget, item, itemsize);
 609                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 610                 t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 611             }
 612             break;
 613
 614         case FF_DECIMAL:
 615             /* If the field is marked with ^ and the value is undefined,
 616                blank it out. */
 617             arg = *fpc++;
 618             if ((arg & 512) && !SvOK(sv)) {
 619                 arg = fieldsize;
 620                 while (arg--)
 621                     *t++ = ' ';
 622                 break;
 623             }
 624             gotsome = TRUE;
 625             value = SvNV(sv);
 626             /* Formats aren't yet marked for locales, so assume "yes". */
 627             {
 628                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 629 #if defined(USE_LONG_DOUBLE)
 630                 if (arg & 256) {
 631                     sprintf(t, "%#*.*" PERL_PRIfldbl,
 632                             (int) fieldsize, (int) arg & 255, value);
 633                 } else {
 634                     sprintf(t, "%*.0" PERL_PRIfldbl, (int) fieldsize, value);
 635                 }
 636 #else
 637                 if (arg & 256) {
 638                     sprintf(t, "%#*.*f",
 639                             (int) fieldsize, (int) arg & 255, value);
 640                 } else {
 641                     sprintf(t, "%*.0f",
 642                             (int) fieldsize, value);
 643                 }
 644 #endif
 645                 RESTORE_NUMERIC_STANDARD();
 646             }
 647             t += fieldsize;
 648             break;
 649
 650         case FF_0DECIMAL:
 651             /* If the field is marked with ^ and the value is undefined,
 652                blank it out. */
 653             arg = *fpc++;
 654             if ((arg & 512) && !SvOK(sv)) {
 655                 arg = fieldsize;
 656                 while (arg--)
 657                     *t++ = ' ';
 658                 break;
 659             }
 660             gotsome = TRUE;
 661             value = SvNV(sv);
 662             /* Formats aren't yet marked for locales, so assume "yes". */
 663             {
 664                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 665 #if defined(USE_LONG_DOUBLE)
 666                 if (arg & 256) {
 667                     sprintf(t, "%#0*.*" PERL_PRIfldbl,
 668                             (int) fieldsize, (int) arg & 255, value);
 669 /* is this legal? I don't have long doubles */
 670                 } else {
 671                     sprintf(t, "%0*.0" PERL_PRIfldbl, (int) fieldsize, value);
 672                 }
 673 #else
 674                 if (arg & 256) {
 675                     sprintf(t, "%#0*.*f",
 676                             (int) fieldsize, (int) arg & 255, value);
 677                 } else {
 678                     sprintf(t, "%0*.0f",
 679                             (int) fieldsize, value);
 680                 }
 681 #endif
 682                 RESTORE_NUMERIC_STANDARD();
 683             }
 684             t += fieldsize;
 685             break;
 686
 687         case FF_NEWLINE:
 688             f++;
 689             while (t-- > linemark && *t == ' ') ;
 690             t++;
 691             *t++ = '\n';
 692             break;
 693
 694         case FF_BLANK:
 695             arg = *fpc++;
 696             if (gotsome) {
 697                 if (arg) {              /* repeat until fields exhausted? */
 698                     *t = '\0';
 699                     SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 700                     lines += FmLINES(PL_formtarget);
 701                     if (lines == 200) {
 702                         arg = t - linemark;
 703                         if (strnEQ(linemark, linemark - arg, arg))
 704                             DIE(aTHX_ "Runaway format");
 705                     }
 706                     FmLINES(PL_formtarget) = lines;
 707                     SP = ORIGMARK;
 708                     RETURNOP(cLISTOP->op_first);
 709                 }
 710             }
 711             else {
 712                 t = linemark;
 713                 lines--;
 714             }
 715             break;
 716
 717         case FF_MORE:
 718             s = chophere;
 719             send = item + len;
 720             if (chopspace) {
 721                 while (*s && isSPACE(*s) && s < send)
 722                     s++;
 723             }
 724             if (s < send) {
 725                 arg = fieldsize - itemsize;
 726                 if (arg) {
 727                     fieldsize -= arg;
 728                     while (arg-- > 0)
 729                         *t++ = ' ';
 730                 }
 731                 s = t - 3;
 732                 if (strnEQ(s,"   ",3)) {
 733                     while (s > SvPVX(PL_formtarget) && isSPACE(s[-1]))
 734                         s--;
 735                 }
 736                 *s++ = '.';
 737                 *s++ = '.';
 738                 *s++ = '.';
 739             }
 740             break;
 741
 742         case FF_END:
 743             *t = '\0';
 744             SvCUR_set(PL_formtarget, t - SvPVX(PL_formtarget));
 745             FmLINES(PL_formtarget) += lines;
 746             SP = ORIGMARK;
 747             RETPUSHYES;
 748         }
 749     }
 750 }
 751
 752 PP(pp_grepstart)
 753 {
 754     dSP;
 755     SV *src;
 756
 757     if (PL_stack_base + *PL_markstack_ptr == SP) {
 758         (void)POPMARK;
 759         if (GIMME_V == G_SCALAR)
 760             XPUSHs(sv_2mortal(newSViv(0)));
 761         RETURNOP(PL_op->op_next->op_next);
 762     }
 763     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
 764     pp_pushmark();                              /* push dst */
 765     pp_pushmark();                              /* push src */
 766     ENTER;                                      /* enter outer scope */
 767
 768     SAVETMPS;
 769     /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
 770     SAVESPTR(DEFSV);
 771     ENTER;                                      /* enter inner scope */
 772     SAVEVPTR(PL_curpm);
 773
 774     src = PL_stack_base[*PL_markstack_ptr];
 775     SvTEMP_off(src);
 776     DEFSV = src;
 777
 778     PUTBACK;
 779     if (PL_op->op_type == OP_MAPSTART)
 780         pp_pushmark();                  /* push top */
 781     return ((LOGOP*)PL_op->op_next)->op_other;
 782 }
 783
 784 PP(pp_mapstart)
 785 {
 786     DIE(aTHX_ "panic: mapstart");       /* uses grepstart */
 787 }
 788
 789 PP(pp_mapwhile)
 790 {
 791     dSP;
 792     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
 793     I32 count;
 794     I32 shift;
 795     SV** src;
 796     SV** dst;
 797
 798     /* first, move source pointer to the next item in the source list */
 799     ++PL_markstack_ptr[-1];
 800
 801     /* if there are new items, push them into the destination list */
 802     if (items) {
 803         /* might need to make room back there first */
 804         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
 805             /* XXX this implementation is very pessimal because the stack
 806              * is repeatedly extended for every set of items.  Is possible
 807              * to do this without any stack extension or copying at all
 808              * by maintaining a separate list over which the map iterates
 809              * (like foreach does). --gsar */
 810
 811             /* everything in the stack after the destination list moves
 812              * towards the end the stack by the amount of room needed */
 813             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
 814
 815             /* items to shift up (accounting for the moved source pointer) */
 816             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
 817
 818             /* This optimization is by Ben Tilly and it does
 819              * things differently from what Sarathy (gsar)
 820              * is describing.  The downside of this optimization is
 821              * that leaves "holes" (uninitialized and hopefully unused areas)
 822              * to the Perl stack, but on the other hand this
 823              * shouldn't be a problem.  If Sarathy's idea gets
 824              * implemented, this optimization should become
 825              * irrelevant.  --jhi */
 826             if (shift < count)
 827                 shift = count; /* Avoid shifting too often --Ben Tilly */
 828
 829             EXTEND(SP,shift);
 830             src = SP;
 831             dst = (SP += shift);
 832             PL_markstack_ptr[-1] += shift;
 833             *PL_markstack_ptr += shift;
 834             while (count--)
 835                 *dst-- = *src--;
 836         }
 837         /* copy the new items down to the destination list */
 838         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
 839         while (items-- > 0)
 840             *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
 841     }
 842     LEAVE;                                      /* exit inner scope */
 843
 844     /* All done yet? */
 845     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
 846         I32 gimme = GIMME_V;
 847
 848         (void)POPMARK;                          /* pop top */
 849         LEAVE;                                  /* exit outer scope */
 850         (void)POPMARK;                          /* pop src */
 851         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
 852         (void)POPMARK;                          /* pop dst */
 853         SP = PL_stack_base + POPMARK;           /* pop original mark */
 854         if (gimme == G_SCALAR) {
 855             dTARGET;
 856             XPUSHi(items);
 857         }
 858         else if (gimme == G_ARRAY)
 859             SP += items;
 860         RETURN;
 861     }
 862     else {
 863         SV *src;
 864
 865         ENTER;                                  /* enter inner scope */
 866         SAVEVPTR(PL_curpm);
 867
 868         /* set $_ to the new source item */
 869         src = PL_stack_base[PL_markstack_ptr[-1]];
 870         SvTEMP_off(src);
 871         DEFSV = src;
 872
 873         RETURNOP(cLOGOP->op_other);
 874     }
 875 }
 876
 877 /* Range stuff. */
 878
 879 PP(pp_range)
 880 {
 881     if (GIMME == G_ARRAY)
 882         return NORMAL;
 883     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
 884         return cLOGOP->op_other;
 885     else
 886         return NORMAL;
 887 }
 888
 889 PP(pp_flip)
 890 {
 891     dSP;
 892
 893     if (GIMME == G_ARRAY) {
 894         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
 895     }
 896     else {
 897         dTOPss;
 898         SV *targ = PAD_SV(PL_op->op_targ);
 899         int flip = 0;
 900
 901         if (PL_op->op_private & OPpFLIP_LINENUM) {
 902             if (GvIO(PL_last_in_gv)) {
 903                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
 904             }
 905             else {
 906                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
 907                 if (gv && GvSV(gv)) flip = SvIV(sv) == SvIV(GvSV(gv));
 908             }
 909         } else {
 910             flip = SvTRUE(sv);
 911         }
 912         if (flip) {
 913             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
 914             if (PL_op->op_flags & OPf_SPECIAL) {
 915                 sv_setiv(targ, 1);
 916                 SETs(targ);
 917                 RETURN;
 918             }
 919             else {
 920                 sv_setiv(targ, 0);
 921                 SP--;
 922                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
 923             }
 924         }
 925         sv_setpv(TARG, "");
 926         SETs(targ);
 927         RETURN;
 928     }
 929 }
 930
 931 PP(pp_flop)
 932 {
 933     dSP;
 934
 935     if (GIMME == G_ARRAY) {
 936         dPOPPOPssrl;
 937         register I32 i, j;
 938         register SV *sv;
 939         I32 max;
 940
 941         if (SvGMAGICAL(left))
 942             mg_get(left);
 943         if (SvGMAGICAL(right))
 944             mg_get(right);
 945
 946         /* This code tries to decide if "$left .. $right" should use the
 947            magical string increment, or if the range is numeric (we make
 948            an exception for .."0" [#18165]). AMS 20021031. */
 949
 950         if (SvNIOKp(left) || !SvPOKp(left) ||
 951             SvNIOKp(right) || !SvPOKp(right) ||
 952             (looks_like_number(left) && *SvPVX(left) != '0' &&
 953              looks_like_number(right)))
 954         {
 955             if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX)
 956                 DIE(aTHX_ "Range iterator outside integer range");
 957             i = SvIV(left);
 958             max = SvIV(right);
 959             if (max >= i) {
 960                 j = max - i + 1;
 961                 EXTEND_MORTAL(j);
 962                 EXTEND(SP, j);
 963             }
 964             else
 965                 j = 0;
 966             while (j--) {
 967                 sv = sv_2mortal(newSViv(i++));
 968                 PUSHs(sv);
 969             }
 970         }
 971         else {
 972             SV *final = sv_mortalcopy(right);
 973             STRLEN len, n_a;
 974             char *tmps = SvPV(final, len);
 975
 976             sv = sv_mortalcopy(left);
 977             SvPV_force(sv,n_a);
 978             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
 979                 XPUSHs(sv);
 980                 if (strEQ(SvPVX(sv),tmps))
 981                     break;
 982                 sv = sv_2mortal(newSVsv(sv));
 983                 sv_inc(sv);
 984             }
 985         }
 986     }
 987     else {
 988         dTOPss;
 989         SV *targ = PAD_SV(cUNOP->op_first->op_targ);
 990         int flop = 0;
 991         sv_inc(targ);
 992
 993         if (PL_op->op_private & OPpFLIP_LINENUM) {
 994             if (GvIO(PL_last_in_gv)) {
 995                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
 996             }
 997             else {
 998                 GV *gv = gv_fetchpv(".", TRUE, SVt_PV);
 999                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1000             }
1001         }
1002         else {
1003             flop = SvTRUE(sv);
1004         }
1005
1006         if (flop) {
1007             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1008             sv_catpv(targ, "E0");
1009         }
1010         SETs(targ);
1011     }
1012
1013     RETURN;
1014 }
1015
1016 /* Control. */
1017
1018 STATIC I32
1019 S_dopoptolabel(pTHX_ char *label)
1020 {
1021     register I32 i;
1022     register PERL_CONTEXT *cx;
1023
1024     for (i = cxstack_ix; i >= 0; i--) {
1025         cx = &cxstack[i];
1026         switch (CxTYPE(cx)) {
1027         case CXt_SUBST:
1028             if (ckWARN(WARN_EXITING))
1029                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
1030                         OP_NAME(PL_op));
1031             break;
1032         case CXt_SUB:
1033             if (ckWARN(WARN_EXITING))
1034                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
1035                         OP_NAME(PL_op));
1036             break;
1037         case CXt_FORMAT:
1038             if (ckWARN(WARN_EXITING))
1039                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
1040                         OP_NAME(PL_op));
1041             break;
1042         case CXt_EVAL:
1043             if (ckWARN(WARN_EXITING))
1044                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
1045                         OP_NAME(PL_op));
1046             break;
1047         case CXt_NULL:
1048             if (ckWARN(WARN_EXITING))
1049                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
1050                         OP_NAME(PL_op));
1051             return -1;
1052         case CXt_LOOP:
1053             if (!cx->blk_loop.label ||
1054               strNE(label, cx->blk_loop.label) ) {
1055                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1056                         (long)i, cx->blk_loop.label));
1057                 continue;
1058             }
1059             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1060             return i;
1061         }
1062     }
1063     return i;
1064 }
1065
1066 I32
1067 Perl_dowantarray(pTHX)
1068 {
1069     I32 gimme = block_gimme();
1070     return (gimme == G_VOID) ? G_SCALAR : gimme;
1071 }
1072
1073 I32
1074 Perl_block_gimme(pTHX)
1075 {
1076     I32 cxix;
1077
1078     cxix = dopoptosub(cxstack_ix);
1079     if (cxix < 0)
1080         return G_VOID;
1081
1082     switch (cxstack[cxix].blk_gimme) {
1083     case G_VOID:
1084         return G_VOID;
1085     case G_SCALAR:
1086         return G_SCALAR;
1087     case G_ARRAY:
1088         return G_ARRAY;
1089     default:
1090         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1091         /* NOTREACHED */
1092         return 0;
1093     }
1094 }
1095
1096 I32
1097 Perl_is_lvalue_sub(pTHX)
1098 {
1099     I32 cxix;
1100
1101     cxix = dopoptosub(cxstack_ix);
1102     assert(cxix >= 0);  /* We should only be called from inside subs */
1103
1104     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1105         return cxstack[cxix].blk_sub.lval;
1106     else
1107         return 0;
1108 }
1109
1110 STATIC I32
1111 S_dopoptosub(pTHX_ I32 startingblock)
1112 {
1113     return dopoptosub_at(cxstack, startingblock);
1114 }
1115
1116 STATIC I32
1117 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1118 {
1119     I32 i;
1120     register PERL_CONTEXT *cx;
1121     for (i = startingblock; i >= 0; i--) {
1122         cx = &cxstk[i];
1123         switch (CxTYPE(cx)) {
1124         default:
1125             continue;
1126         case CXt_EVAL:
1127         case CXt_SUB:
1128         case CXt_FORMAT:
1129             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1130             return i;
1131         }
1132     }
1133     return i;
1134 }
1135
1136 STATIC I32
1137 S_dopoptoeval(pTHX_ I32 startingblock)
1138 {
1139     I32 i;
1140     register PERL_CONTEXT *cx;
1141     for (i = startingblock; i >= 0; i--) {
1142         cx = &cxstack[i];
1143         switch (CxTYPE(cx)) {
1144         default:
1145             continue;
1146         case CXt_EVAL:
1147             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1148             return i;
1149         }
1150     }
1151     return i;
1152 }
1153
1154 STATIC I32
1155 S_dopoptoloop(pTHX_ I32 startingblock)
1156 {
1157     I32 i;
1158     register PERL_CONTEXT *cx;
1159     for (i = startingblock; i >= 0; i--) {
1160         cx = &cxstack[i];
1161         switch (CxTYPE(cx)) {
1162         case CXt_SUBST:
1163             if (ckWARN(WARN_EXITING))
1164                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting substitution via %s",
1165                         OP_NAME(PL_op));
1166             break;
1167         case CXt_SUB:
1168             if (ckWARN(WARN_EXITING))
1169                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting subroutine via %s",
1170                         OP_NAME(PL_op));
1171             break;
1172         case CXt_FORMAT:
1173             if (ckWARN(WARN_EXITING))
1174                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting format via %s",
1175                         OP_NAME(PL_op));
1176             break;
1177         case CXt_EVAL:
1178             if (ckWARN(WARN_EXITING))
1179                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting eval via %s",
1180                         OP_NAME(PL_op));
1181             break;
1182         case CXt_NULL:
1183             if (ckWARN(WARN_EXITING))
1184                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting pseudo-block via %s",
1185                         OP_NAME(PL_op));
1186             return -1;
1187         case CXt_LOOP:
1188             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1189             return i;
1190         }
1191     }
1192     return i;
1193 }
1194
1195 void
1196 Perl_dounwind(pTHX_ I32 cxix)
1197 {
1198     register PERL_CONTEXT *cx;
1199     I32 optype;
1200
1201     while (cxstack_ix > cxix) {
1202         SV *sv;
1203         cx = &cxstack[cxstack_ix];
1204         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1205                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1206         /* Note: we don't need to restore the base context info till the end. */
1207         switch (CxTYPE(cx)) {
1208         case CXt_SUBST:
1209             POPSUBST(cx);
1210             continue;  /* not break */
1211         case CXt_SUB:
1212             POPSUB(cx,sv);
1213             LEAVESUB(sv);
1214             break;
1215         case CXt_EVAL:
1216             POPEVAL(cx);
1217             break;
1218         case CXt_LOOP:
1219             POPLOOP(cx);
1220             break;
1221         case CXt_NULL:
1222             break;
1223         case CXt_FORMAT:
1224             POPFORMAT(cx);
1225             break;
1226         }
1227         cxstack_ix--;
1228     }
1229 }
1230
1231 void
1232 Perl_qerror(pTHX_ SV *err)
1233 {
1234     if (PL_in_eval)
1235         sv_catsv(ERRSV, err);
1236     else if (PL_errors)
1237         sv_catsv(PL_errors, err);
1238     else
1239         Perl_warn(aTHX_ "%"SVf, err);
1240     ++PL_error_count;
1241 }
1242
1243 OP *
1244 Perl_die_where(pTHX_ char *message, STRLEN msglen)
1245 {
1246     STRLEN n_a;
1247     IO *io;
1248     MAGIC *mg;
1249
1250     if (PL_in_eval) {
1251         I32 cxix;
1252         register PERL_CONTEXT *cx;
1253         I32 gimme;
1254         SV **newsp;
1255
1256         if (message) {
1257             if (PL_in_eval & EVAL_KEEPERR) {
1258                 static char prefix[] = "\t(in cleanup) ";
1259                 SV *err = ERRSV;
1260                 char *e = Nullch;
1261                 if (!SvPOK(err))
1262                     sv_setpv(err,"");
1263                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1264                     e = SvPV(err, n_a);
1265                     e += n_a - msglen;
1266                     if (*e != *message || strNE(e,message))
1267                         e = Nullch;
1268                 }
1269                 if (!e) {
1270                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1271                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1272                     sv_catpvn(err, message, msglen);
1273                     if (ckWARN(WARN_MISC)) {
1274                         STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1275                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1276                     }
1277                 }
1278             }
1279             else {
1280                 sv_setpvn(ERRSV, message, msglen);
1281             }
1282         }
1283         else
1284             message = SvPVx(ERRSV, msglen);
1285
1286         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1287                && PL_curstackinfo->si_prev)
1288         {
1289             dounwind(-1);
1290             POPSTACK;
1291         }
1292
1293         if (cxix >= 0) {
1294             I32 optype;
1295
1296             if (cxix < cxstack_ix)
1297                 dounwind(cxix);
1298
1299             POPBLOCK(cx,PL_curpm);
1300             if (CxTYPE(cx) != CXt_EVAL) {
1301                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1302                 PerlIO_write(Perl_error_log, message, msglen);
1303                 my_exit(1);
1304             }
1305             POPEVAL(cx);
1306
1307             if (gimme == G_SCALAR)
1308                 *++newsp = &PL_sv_undef;
1309             PL_stack_sp = newsp;
1310
1311             LEAVE;
1312
1313             /* LEAVE could clobber PL_curcop (see save_re_context())
1314              * XXX it might be better to find a way to avoid messing with
1315              * PL_curcop in save_re_context() instead, but this is a more
1316              * minimal fix --GSAR */
1317             PL_curcop = cx->blk_oldcop;
1318
1319             if (optype == OP_REQUIRE) {
1320                 char* msg = SvPVx(ERRSV, n_a);
1321                 DIE(aTHX_ "%sCompilation failed in require",
1322                     *msg ? msg : "Unknown error\n");
1323             }
1324             return pop_return();
1325         }
1326     }
1327     if (!message)
1328         message = SvPVx(ERRSV, msglen);
1329
1330     /* if STDERR is tied, print to it instead */
1331     if (PL_stderrgv && (io = GvIOp(PL_stderrgv))
1332         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1333         dSP; ENTER;
1334         PUSHMARK(SP);
1335         XPUSHs(SvTIED_obj((SV*)io, mg));
1336         XPUSHs(sv_2mortal(newSVpvn(message, msglen)));
1337         PUTBACK;
1338         call_method("PRINT", G_SCALAR);
1339         LEAVE;
1340     }
1341     else {
1342 #ifdef USE_SFIO
1343         /* SFIO can really mess with your errno */
1344         int e = errno;
1345 #endif
1346         PerlIO *serr = Perl_error_log;
1347
1348         PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen);
1349         (void)PerlIO_flush(serr);
1350 #ifdef USE_SFIO
1351         errno = e;
1352 #endif
1353     }
1354     my_failure_exit();
1355     /* NOTREACHED */
1356     return 0;
1357 }
1358
1359 PP(pp_xor)
1360 {
1361     dSP; dPOPTOPssrl;
1362     if (SvTRUE(left) != SvTRUE(right))
1363         RETSETYES;
1364     else
1365         RETSETNO;
1366 }
1367
1368 PP(pp_andassign)
1369 {
1370     dSP;
1371     if (!SvTRUE(TOPs))
1372         RETURN;
1373     else
1374         RETURNOP(cLOGOP->op_other);
1375 }
1376
1377 PP(pp_orassign)
1378 {
1379     dSP;
1380     if (SvTRUE(TOPs))
1381         RETURN;
1382     else
1383         RETURNOP(cLOGOP->op_other);
1384 }
1385
1386 PP(pp_dorassign)
1387 {
1388     dSP;
1389     register SV* sv;
1390
1391     sv = TOPs;
1392     if (!sv || !SvANY(sv)) {
1393         RETURNOP(cLOGOP->op_other);
1394     }
1395
1396     switch (SvTYPE(sv)) {
1397     case SVt_PVAV:
1398         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1399             RETURN;
1400         break;
1401     case SVt_PVHV:
1402         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1403             RETURN;
1404         break;
1405     case SVt_PVCV:
1406         if (CvROOT(sv) || CvXSUB(sv))
1407             RETURN;
1408         break;
1409     default:
1410         if (SvGMAGICAL(sv))
1411             mg_get(sv);
1412         if (SvOK(sv))
1413             RETURN;
1414     }
1415
1416     RETURNOP(cLOGOP->op_other);
1417 }
1418
1419 PP(pp_caller)
1420 {
1421     dSP;
1422     register I32 cxix = dopoptosub(cxstack_ix);
1423     register PERL_CONTEXT *cx;
1424     register PERL_CONTEXT *ccstack = cxstack;
1425     PERL_SI *top_si = PL_curstackinfo;
1426     I32 dbcxix;
1427     I32 gimme;
1428     char *stashname;
1429     SV *sv;
1430     I32 count = 0;
1431
1432     if (MAXARG)
1433         count = POPi;
1434
1435     for (;;) {
1436         /* we may be in a higher stacklevel, so dig down deeper */
1437         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1438             top_si = top_si->si_prev;
1439             ccstack = top_si->si_cxstack;
1440             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1441         }
1442         if (cxix < 0) {
1443             if (GIMME != G_ARRAY) {
1444                 EXTEND(SP, 1);
1445                 RETPUSHUNDEF;
1446             }
1447             RETURN;
1448         }
1449         if (PL_DBsub && cxix >= 0 &&
1450                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1451             count++;
1452         if (!count--)
1453             break;
1454         cxix = dopoptosub_at(ccstack, cxix - 1);
1455     }
1456
1457     cx = &ccstack[cxix];
1458     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1459         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1460         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1461            field below is defined for any cx. */
1462         if (PL_DBsub && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1463             cx = &ccstack[dbcxix];
1464     }
1465
1466     stashname = CopSTASHPV(cx->blk_oldcop);
1467     if (GIMME != G_ARRAY) {
1468         EXTEND(SP, 1);
1469         if (!stashname)
1470             PUSHs(&PL_sv_undef);
1471         else {
1472             dTARGET;
1473             sv_setpv(TARG, stashname);
1474             PUSHs(TARG);
1475         }
1476         RETURN;
1477     }
1478
1479     EXTEND(SP, 10);
1480
1481     if (!stashname)
1482         PUSHs(&PL_sv_undef);
1483     else
1484         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1485     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1486     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1487     if (!MAXARG)
1488         RETURN;
1489     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1490         GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1491         /* So is ccstack[dbcxix]. */
1492         if (isGV(cvgv)) {
1493             sv = NEWSV(49, 0);
1494             gv_efullname3(sv, cvgv, Nullch);
1495             PUSHs(sv_2mortal(sv));
1496             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1497         }
1498         else {
1499             PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1500             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1501         }
1502     }
1503     else {
1504         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1505         PUSHs(sv_2mortal(newSViv(0)));
1506     }
1507     gimme = (I32)cx->blk_gimme;
1508     if (gimme == G_VOID)
1509         PUSHs(&PL_sv_undef);
1510     else
1511         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1512     if (CxTYPE(cx) == CXt_EVAL) {
1513         /* eval STRING */
1514         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1515             PUSHs(cx->blk_eval.cur_text);
1516             PUSHs(&PL_sv_no);
1517         }
1518         /* require */
1519         else if (cx->blk_eval.old_namesv) {
1520             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1521             PUSHs(&PL_sv_yes);
1522         }
1523         /* eval BLOCK (try blocks have old_namesv == 0) */
1524         else {
1525             PUSHs(&PL_sv_undef);
1526             PUSHs(&PL_sv_undef);
1527         }
1528     }
1529     else {
1530         PUSHs(&PL_sv_undef);
1531         PUSHs(&PL_sv_undef);
1532     }
1533     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1534         && CopSTASH_eq(PL_curcop, PL_debstash))
1535     {
1536         AV *ary = cx->blk_sub.argarray;
1537         int off = AvARRAY(ary) - AvALLOC(ary);
1538
1539         if (!PL_dbargs) {
1540             GV* tmpgv;
1541             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1542                                 SVt_PVAV)));
1543             GvMULTI_on(tmpgv);
1544             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1545         }
1546
1547         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1548             av_extend(PL_dbargs, AvFILLp(ary) + off);
1549         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1550         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1551     }
1552     /* XXX only hints propagated via op_private are currently
1553      * visible (others are not easily accessible, since they
1554      * use the global PL_hints) */
1555     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1556                              HINT_PRIVATE_MASK)));
1557     {
1558         SV * mask ;
1559         SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1560
1561         if  (old_warnings == pWARN_NONE ||
1562                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1563             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1564         else if (old_warnings == pWARN_ALL ||
1565                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
1566             mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1567         else
1568             mask = newSVsv(old_warnings);
1569         PUSHs(sv_2mortal(mask));
1570     }
1571     RETURN;
1572 }
1573
1574 PP(pp_reset)
1575 {
1576     dSP;
1577     char *tmps;
1578     STRLEN n_a;
1579
1580     if (MAXARG < 1)
1581         tmps = "";
1582     else
1583         tmps = POPpx;
1584     sv_reset(tmps, CopSTASH(PL_curcop));
1585     PUSHs(&PL_sv_yes);
1586     RETURN;
1587 }
1588
1589 PP(pp_lineseq)
1590 {
1591     return NORMAL;
1592 }
1593
1594 /* like pp_nextstate, but used instead when the debugger is active */
1595
1596 PP(pp_dbstate)
1597 {
1598     PL_curcop = (COP*)PL_op;
1599     TAINT_NOT;          /* Each statement is presumed innocent */
1600     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1601     FREETMPS;
1602
1603     if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1604     {
1605         dSP;
1606         register CV *cv;
1607         register PERL_CONTEXT *cx;
1608         I32 gimme = G_ARRAY;
1609         U8 hasargs;
1610         GV *gv;
1611
1612         gv = PL_DBgv;
1613         cv = GvCV(gv);
1614         if (!cv)
1615             DIE(aTHX_ "No DB::DB routine defined");
1616
1617         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1618             /* don't do recursive DB::DB call */
1619             return NORMAL;
1620
1621         ENTER;
1622         SAVETMPS;
1623
1624         SAVEI32(PL_debug);
1625         SAVESTACK_POS();
1626         PL_debug = 0;
1627         hasargs = 0;
1628         SPAGAIN;
1629
1630         push_return(PL_op->op_next);
1631         PUSHBLOCK(cx, CXt_SUB, SP);
1632         PUSHSUB(cx);
1633         CvDEPTH(cv)++;
1634         (void)SvREFCNT_inc(cv);
1635         PAD_SET_CUR(CvPADLIST(cv),1);
1636         RETURNOP(CvSTART(cv));
1637     }
1638     else
1639         return NORMAL;
1640 }
1641
1642 PP(pp_scope)
1643 {
1644     return NORMAL;
1645 }
1646
1647 PP(pp_enteriter)
1648 {
1649     dSP; dMARK;
1650     register PERL_CONTEXT *cx;
1651     I32 gimme = GIMME_V;
1652     SV **svp;
1653     U32 cxtype = CXt_LOOP;
1654 #ifdef USE_ITHREADS
1655     void *iterdata;
1656 #endif
1657
1658     ENTER;
1659     SAVETMPS;
1660
1661     if (PL_op->op_targ) {
1662 #ifndef USE_ITHREADS
1663         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1664         SAVESPTR(*svp);
1665 #else
1666         SAVEPADSV(PL_op->op_targ);
1667         iterdata = INT2PTR(void*, PL_op->op_targ);
1668         cxtype |= CXp_PADVAR;
1669 #endif
1670     }
1671     else {
1672         GV *gv = (GV*)POPs;
1673         svp = &GvSV(gv);                        /* symbol table variable */
1674         SAVEGENERICSV(*svp);
1675         *svp = NEWSV(0,0);
1676 #ifdef USE_ITHREADS
1677         iterdata = (void*)gv;
1678 #endif
1679     }
1680
1681     ENTER;
1682
1683     PUSHBLOCK(cx, cxtype, SP);
1684 #ifdef USE_ITHREADS
1685     PUSHLOOP(cx, iterdata, MARK);
1686 #else
1687     PUSHLOOP(cx, svp, MARK);
1688 #endif
1689     if (PL_op->op_flags & OPf_STACKED) {
1690         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1691         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1692             dPOPss;
1693             /* See comment in pp_flop() */
1694             if (SvNIOKp(sv) || !SvPOKp(sv) ||
1695                 SvNIOKp(cx->blk_loop.iterary) || !SvPOKp(cx->blk_loop.iterary) ||
1696                 (looks_like_number(sv) && *SvPVX(sv) != '0' &&
1697                  looks_like_number((SV*)cx->blk_loop.iterary)))
1698             {
1699                  if (SvNV(sv) < IV_MIN ||
1700                      SvNV((SV*)cx->blk_loop.iterary) >= IV_MAX)
1701                      DIE(aTHX_ "Range iterator outside integer range");
1702                  cx->blk_loop.iterix = SvIV(sv);
1703                  cx->blk_loop.itermax = SvIV((SV*)cx->blk_loop.iterary);
1704             }
1705             else
1706                 cx->blk_loop.iterlval = newSVsv(sv);
1707         }
1708     }
1709     else {
1710         cx->blk_loop.iterary = PL_curstack;
1711         AvFILLp(PL_curstack) = SP - PL_stack_base;
1712         cx->blk_loop.iterix = MARK - PL_stack_base;
1713     }
1714
1715     RETURN;
1716 }
1717
1718 PP(pp_enterloop)
1719 {
1720     dSP;
1721     register PERL_CONTEXT *cx;
1722     I32 gimme = GIMME_V;
1723
1724     ENTER;
1725     SAVETMPS;
1726     ENTER;
1727
1728     PUSHBLOCK(cx, CXt_LOOP, SP);
1729     PUSHLOOP(cx, 0, SP);
1730
1731     RETURN;
1732 }
1733
1734 PP(pp_leaveloop)
1735 {
1736     dSP;
1737     register PERL_CONTEXT *cx;
1738     I32 gimme;
1739     SV **newsp;
1740     PMOP *newpm;
1741     SV **mark;
1742
1743     POPBLOCK(cx,newpm);
1744     mark = newsp;
1745     newsp = PL_stack_base + cx->blk_loop.resetsp;
1746
1747     TAINT_NOT;
1748     if (gimme == G_VOID)
1749         ; /* do nothing */
1750     else if (gimme == G_SCALAR) {
1751         if (mark < SP)
1752             *++newsp = sv_mortalcopy(*SP);
1753         else
1754             *++newsp = &PL_sv_undef;
1755     }
1756     else {
1757         while (mark < SP) {
1758             *++newsp = sv_mortalcopy(*++mark);
1759             TAINT_NOT;          /* Each item is independent */
1760         }
1761     }
1762     SP = newsp;
1763     PUTBACK;
1764
1765     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1766     PL_curpm = newpm;   /* ... and pop $1 et al */
1767
1768     LEAVE;
1769     LEAVE;
1770
1771     return NORMAL;
1772 }
1773
1774 PP(pp_return)
1775 {
1776     dSP; dMARK;
1777     I32 cxix;
1778     register PERL_CONTEXT *cx;
1779     bool popsub2 = FALSE;
1780     bool clear_errsv = FALSE;
1781     I32 gimme;
1782     SV **newsp;
1783     PMOP *newpm;
1784     I32 optype = 0;
1785     SV *sv;
1786
1787     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1788         if (cxstack_ix == PL_sortcxix
1789             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1790         {
1791             if (cxstack_ix > PL_sortcxix)
1792                 dounwind(PL_sortcxix);
1793             AvARRAY(PL_curstack)[1] = *SP;
1794             PL_stack_sp = PL_stack_base + 1;
1795             return 0;
1796         }
1797     }
1798
1799     cxix = dopoptosub(cxstack_ix);
1800     if (cxix < 0)
1801         DIE(aTHX_ "Can't return outside a subroutine");
1802     if (cxix < cxstack_ix)
1803         dounwind(cxix);
1804
1805     POPBLOCK(cx,newpm);
1806     switch (CxTYPE(cx)) {
1807     case CXt_SUB:
1808         popsub2 = TRUE;
1809         break;
1810     case CXt_EVAL:
1811         if (!(PL_in_eval & EVAL_KEEPERR))
1812             clear_errsv = TRUE;
1813         POPEVAL(cx);
1814         if (CxTRYBLOCK(cx))
1815             break;
1816         lex_end();
1817         if (optype == OP_REQUIRE &&
1818             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1819         {
1820             /* Unassume the success we assumed earlier. */
1821             SV *nsv = cx->blk_eval.old_namesv;
1822             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1823             DIE(aTHX_ "%s did not return a true value", SvPVX(nsv));
1824         }
1825         break;
1826     case CXt_FORMAT:
1827         POPFORMAT(cx);
1828         break;
1829     default:
1830         DIE(aTHX_ "panic: return");
1831     }
1832
1833     TAINT_NOT;
1834     if (gimme == G_SCALAR) {
1835         if (MARK < SP) {
1836             if (popsub2) {
1837                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1838                     if (SvTEMP(TOPs)) {
1839                         *++newsp = SvREFCNT_inc(*SP);
1840                         FREETMPS;
1841                         sv_2mortal(*newsp);
1842                     }
1843                     else {
1844                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1845                         FREETMPS;
1846                         *++newsp = sv_mortalcopy(sv);
1847                         SvREFCNT_dec(sv);
1848                     }
1849                 }
1850                 else
1851                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
1852             }
1853             else
1854                 *++newsp = sv_mortalcopy(*SP);
1855         }
1856         else
1857             *++newsp = &PL_sv_undef;
1858     }
1859     else if (gimme == G_ARRAY) {
1860         while (++MARK <= SP) {
1861             *++newsp = (popsub2 && SvTEMP(*MARK))
1862                         ? *MARK : sv_mortalcopy(*MARK);
1863             TAINT_NOT;          /* Each item is independent */
1864         }
1865     }
1866     PL_stack_sp = newsp;
1867
1868     /* Stack values are safe: */
1869     if (popsub2) {
1870         POPSUB(cx,sv);  /* release CV and @_ ... */
1871     }
1872     else
1873         sv = Nullsv;
1874     PL_curpm = newpm;   /* ... and pop $1 et al */
1875
1876     LEAVE;
1877     LEAVESUB(sv);
1878     if (clear_errsv)
1879         sv_setpv(ERRSV,"");
1880     return pop_return();
1881 }
1882
1883 PP(pp_last)
1884 {
1885     dSP;
1886     I32 cxix;
1887     register PERL_CONTEXT *cx;
1888     I32 pop2 = 0;
1889     I32 gimme;
1890     I32 optype;
1891     OP *nextop;
1892     SV **newsp;
1893     PMOP *newpm;
1894     SV **mark;
1895     SV *sv = Nullsv;
1896
1897     if (PL_op->op_flags & OPf_SPECIAL) {
1898         cxix = dopoptoloop(cxstack_ix);
1899         if (cxix < 0)
1900             DIE(aTHX_ "Can't \"last\" outside a loop block");
1901     }
1902     else {
1903         cxix = dopoptolabel(cPVOP->op_pv);
1904         if (cxix < 0)
1905             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
1906     }
1907     if (cxix < cxstack_ix)
1908         dounwind(cxix);
1909
1910     POPBLOCK(cx,newpm);
1911     mark = newsp;
1912     switch (CxTYPE(cx)) {
1913     case CXt_LOOP:
1914         pop2 = CXt_LOOP;
1915         newsp = PL_stack_base + cx->blk_loop.resetsp;
1916         nextop = cx->blk_loop.last_op->op_next;
1917         break;
1918     case CXt_SUB:
1919         pop2 = CXt_SUB;
1920         nextop = pop_return();
1921         break;
1922     case CXt_EVAL:
1923         POPEVAL(cx);
1924         nextop = pop_return();
1925         break;
1926     case CXt_FORMAT:
1927         POPFORMAT(cx);
1928         nextop = pop_return();
1929         break;
1930     default:
1931         DIE(aTHX_ "panic: last");
1932     }
1933
1934     TAINT_NOT;
1935     if (gimme == G_SCALAR) {
1936         if (MARK < SP)
1937             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
1938                         ? *SP : sv_mortalcopy(*SP);
1939         else
1940             *++newsp = &PL_sv_undef;
1941     }
1942     else if (gimme == G_ARRAY) {
1943         while (++MARK <= SP) {
1944             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
1945                         ? *MARK : sv_mortalcopy(*MARK);
1946             TAINT_NOT;          /* Each item is independent */
1947         }
1948     }
1949     SP = newsp;
1950     PUTBACK;
1951
1952     /* Stack values are safe: */
1953     switch (pop2) {
1954     case CXt_LOOP:
1955         POPLOOP(cx);    /* release loop vars ... */
1956         LEAVE;
1957         break;
1958     case CXt_SUB:
1959         POPSUB(cx,sv);  /* release CV and @_ ... */
1960         break;
1961     }
1962     PL_curpm = newpm;   /* ... and pop $1 et al */
1963
1964     LEAVE;
1965     LEAVESUB(sv);
1966     return nextop;
1967 }
1968
1969 PP(pp_next)
1970 {
1971     I32 cxix;
1972     register PERL_CONTEXT *cx;
1973     I32 inner;
1974
1975     if (PL_op->op_flags & OPf_SPECIAL) {
1976         cxix = dopoptoloop(cxstack_ix);
1977         if (cxix < 0)
1978             DIE(aTHX_ "Can't \"next\" outside a loop block");
1979     }
1980     else {
1981         cxix = dopoptolabel(cPVOP->op_pv);
1982         if (cxix < 0)
1983             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
1984     }
1985     if (cxix < cxstack_ix)
1986         dounwind(cxix);
1987
1988     /* clear off anything above the scope we're re-entering, but
1989      * save the rest until after a possible continue block */
1990     inner = PL_scopestack_ix;
1991     TOPBLOCK(cx);
1992     if (PL_scopestack_ix < inner)
1993         leave_scope(PL_scopestack[PL_scopestack_ix]);
1994     return cx->blk_loop.next_op;
1995 }
1996
1997 PP(pp_redo)
1998 {
1999     I32 cxix;
2000     register PERL_CONTEXT *cx;
2001     I32 oldsave;
2002
2003     if (PL_op->op_flags & OPf_SPECIAL) {
2004         cxix = dopoptoloop(cxstack_ix);
2005         if (cxix < 0)
2006             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2007     }
2008     else {
2009         cxix = dopoptolabel(cPVOP->op_pv);
2010         if (cxix < 0)
2011             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2012     }
2013     if (cxix < cxstack_ix)
2014         dounwind(cxix);
2015
2016     TOPBLOCK(cx);
2017     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2018     LEAVE_SCOPE(oldsave);
2019     return cx->blk_loop.redo_op;
2020 }
2021
2022 STATIC OP *
2023 S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
2024 {
2025     OP *kid = Nullop;
2026     OP **ops = opstack;
2027     static char too_deep[] = "Target of goto is too deeply nested";
2028
2029     if (ops >= oplimit)
2030         Perl_croak(aTHX_ too_deep);
2031     if (o->op_type == OP_LEAVE ||
2032         o->op_type == OP_SCOPE ||
2033         o->op_type == OP_LEAVELOOP ||
2034         o->op_type == OP_LEAVETRY)
2035     {
2036         *ops++ = cUNOPo->op_first;
2037         if (ops >= oplimit)
2038             Perl_croak(aTHX_ too_deep);
2039     }
2040     *ops = 0;
2041     if (o->op_flags & OPf_KIDS) {
2042         /* First try all the kids at this level, since that's likeliest. */
2043         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2044             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2045                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2046                 return kid;
2047         }
2048         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2049             if (kid == PL_lastgotoprobe)
2050                 continue;
2051             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2052                 if (ops == opstack)
2053                     *ops++ = kid;
2054                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2055                          ops[-1]->op_type == OP_DBSTATE)
2056                     ops[-1] = kid;
2057                 else
2058                     *ops++ = kid;
2059             }
2060             if ((o = dofindlabel(kid, label, ops, oplimit)))
2061                 return o;
2062         }
2063     }
2064     *ops = 0;
2065     return 0;
2066 }
2067
2068 PP(pp_dump)
2069 {
2070     return pp_goto();
2071     /*NOTREACHED*/
2072 }
2073
2074 PP(pp_goto)
2075 {
2076     dSP;
2077     OP *retop = 0;
2078     I32 ix;
2079     register PERL_CONTEXT *cx;
2080 #define GOTO_DEPTH 64
2081     OP *enterops[GOTO_DEPTH];
2082     char *label;
2083     int do_dump = (PL_op->op_type == OP_DUMP);
2084     static char must_have_label[] = "goto must have label";
2085
2086     label = 0;
2087     if (PL_op->op_flags & OPf_STACKED) {
2088         SV *sv = POPs;
2089         STRLEN n_a;
2090
2091         /* This egregious kludge implements goto &subroutine */
2092         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2093             I32 cxix;
2094             register PERL_CONTEXT *cx;
2095             CV* cv = (CV*)SvRV(sv);
2096             SV** mark;
2097             I32 items = 0;
2098             I32 oldsave;
2099
2100         retry:
2101             if (!CvROOT(cv) && !CvXSUB(cv)) {
2102                 GV *gv = CvGV(cv);
2103                 GV *autogv;
2104                 if (gv) {
2105                     SV *tmpstr;
2106                     /* autoloaded stub? */
2107                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2108                         goto retry;
2109                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2110                                           GvNAMELEN(gv), FALSE);
2111                     if (autogv && (cv = GvCV(autogv)))
2112                         goto retry;
2113                     tmpstr = sv_newmortal();
2114                     gv_efullname3(tmpstr, gv, Nullch);
2115                     DIE(aTHX_ "Goto undefined subroutine &%s",SvPVX(tmpstr));
2116                 }
2117                 DIE(aTHX_ "Goto undefined subroutine");
2118             }
2119
2120             /* First do some returnish stuff. */
2121             cxix = dopoptosub(cxstack_ix);
2122             if (cxix < 0)
2123                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2124             if (cxix < cxstack_ix)
2125                 dounwind(cxix);
2126             TOPBLOCK(cx);
2127             if (CxREALEVAL(cx))
2128                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2129             mark = PL_stack_sp;
2130             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2131                 /* put @_ back onto stack */
2132                 AV* av = cx->blk_sub.argarray;
2133
2134                 items = AvFILLp(av) + 1;
2135                 PL_stack_sp++;
2136                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2137                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2138                 PL_stack_sp += items;
2139                 SvREFCNT_dec(GvAV(PL_defgv));
2140                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2141                 /* abandon @_ if it got reified */
2142                 if (AvREAL(av)) {
2143                     (void)sv_2mortal((SV*)av);  /* delay until return */
2144                     av = newAV();
2145                     av_extend(av, items-1);
2146                     AvFLAGS(av) = AVf_REIFY;
2147                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2148                 }
2149             }
2150             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2151                 AV* av;
2152                 av = GvAV(PL_defgv);
2153                 items = AvFILLp(av) + 1;
2154                 PL_stack_sp++;
2155                 EXTEND(PL_stack_sp, items); /* @_ could have been extended. */
2156                 Copy(AvARRAY(av), PL_stack_sp, items, SV*);
2157                 PL_stack_sp += items;
2158             }
2159             if (CxTYPE(cx) == CXt_SUB &&
2160                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2161                 SvREFCNT_dec(cx->blk_sub.cv);
2162             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2163             LEAVE_SCOPE(oldsave);
2164
2165             /* Now do some callish stuff. */
2166             SAVETMPS;
2167             if (CvXSUB(cv)) {
2168 #ifdef PERL_XSUB_OLDSTYLE
2169                 if (CvOLDSTYLE(cv)) {
2170                     I32 (*fp3)(int,int,int);
2171                     while (SP > mark) {
2172                         SP[1] = SP[0];
2173                         SP--;
2174                     }
2175                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2176                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2177                                    mark - PL_stack_base + 1,
2178                                    items);
2179                     SP = PL_stack_base + items;
2180                 }
2181                 else
2182 #endif /* PERL_XSUB_OLDSTYLE */
2183                 {
2184                     SV **newsp;
2185                     I32 gimme;
2186
2187                     PL_stack_sp--;              /* There is no cv arg. */
2188                     /* Push a mark for the start of arglist */
2189                     PUSHMARK(mark);
2190                     (void)(*CvXSUB(cv))(aTHX_ cv);
2191                     /* Pop the current context like a decent sub should */
2192                     POPBLOCK(cx, PL_curpm);
2193                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2194                 }
2195                 LEAVE;
2196                 return pop_return();
2197             }
2198             else {
2199                 AV* padlist = CvPADLIST(cv);
2200                 if (CxTYPE(cx) == CXt_EVAL) {
2201                     PL_in_eval = cx->blk_eval.old_in_eval;
2202                     PL_eval_root = cx->blk_eval.old_eval_root;
2203                     cx->cx_type = CXt_SUB;
2204                     cx->blk_sub.hasargs = 0;
2205                 }
2206                 cx->blk_sub.cv = cv;
2207                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2208
2209                 CvDEPTH(cv)++;
2210                 if (CvDEPTH(cv) < 2)
2211                     (void)SvREFCNT_inc(cv);
2212                 else {
2213                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2214                         sub_crush_depth(cv);
2215                     pad_push(padlist, CvDEPTH(cv), cx->blk_sub.hasargs);
2216                 }
2217                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2218                 if (cx->blk_sub.hasargs)
2219                 {
2220                     AV* av = (AV*)PAD_SVl(0);
2221                     SV** ary;
2222
2223                     cx->blk_sub.savearray = GvAV(PL_defgv);
2224                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2225                     CX_CURPAD_SAVE(cx->blk_sub);
2226                     cx->blk_sub.argarray = av;
2227                     ++mark;
2228
2229                     if (items >= AvMAX(av) + 1) {
2230                         ary = AvALLOC(av);
2231                         if (AvARRAY(av) != ary) {
2232                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2233                             SvPVX(av) = (char*)ary;
2234                         }
2235                         if (items >= AvMAX(av) + 1) {
2236                             AvMAX(av) = items - 1;
2237                             Renew(ary,items+1,SV*);
2238                             AvALLOC(av) = ary;
2239                             SvPVX(av) = (char*)ary;
2240                         }
2241                     }
2242                     Copy(mark,AvARRAY(av),items,SV*);
2243                     AvFILLp(av) = items - 1;
2244                     assert(!AvREAL(av));
2245                     while (items--) {
2246                         if (*mark)
2247                             SvTEMP_off(*mark);
2248                         mark++;
2249                     }
2250                 }
2251                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2252                     /*
2253                      * We do not care about using sv to call CV;
2254                      * it's for informational purposes only.
2255                      */
2256                     SV *sv = GvSV(PL_DBsub);
2257                     CV *gotocv;
2258
2259                     if (PERLDB_SUB_NN) {
2260                         SvIVX(sv) = PTR2IV(cv); /* Already upgraded, saved */
2261                     } else {
2262                         save_item(sv);
2263                         gv_efullname3(sv, CvGV(cv), Nullch);
2264                     }
2265                     if (  PERLDB_GOTO
2266                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2267                         PUSHMARK( PL_stack_sp );
2268                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2269                         PL_stack_sp--;
2270                     }
2271                 }
2272                 RETURNOP(CvSTART(cv));
2273             }
2274         }
2275         else {
2276             label = SvPV(sv,n_a);
2277             if (!(do_dump || *label))
2278                 DIE(aTHX_ must_have_label);
2279         }
2280     }
2281     else if (PL_op->op_flags & OPf_SPECIAL) {
2282         if (! do_dump)
2283             DIE(aTHX_ must_have_label);
2284     }
2285     else
2286         label = cPVOP->op_pv;
2287
2288     if (label && *label) {
2289         OP *gotoprobe = 0;
2290         bool leaving_eval = FALSE;
2291         PERL_CONTEXT *last_eval_cx = 0;
2292
2293         /* find label */
2294
2295         PL_lastgotoprobe = 0;
2296         *enterops = 0;
2297         for (ix = cxstack_ix; ix >= 0; ix--) {
2298             cx = &cxstack[ix];
2299             switch (CxTYPE(cx)) {
2300             case CXt_EVAL:
2301                 leaving_eval = TRUE;
2302                 if (CxREALEVAL(cx)) {
2303                     gotoprobe = (last_eval_cx ?
2304                                 last_eval_cx->blk_eval.old_eval_root :
2305                                 PL_eval_root);
2306                     last_eval_cx = cx;
2307                     break;
2308                 }
2309                 /* else fall through */
2310             case CXt_LOOP:
2311                 gotoprobe = cx->blk_oldcop->op_sibling;
2312                 break;
2313             case CXt_SUBST:
2314                 continue;
2315             case CXt_BLOCK:
2316                 if (ix)
2317                     gotoprobe = cx->blk_oldcop->op_sibling;
2318                 else
2319                     gotoprobe = PL_main_root;
2320                 break;
2321             case CXt_SUB:
2322                 if (CvDEPTH(cx->blk_sub.cv)) {
2323                     gotoprobe = CvROOT(cx->blk_sub.cv);
2324                     break;
2325                 }
2326                 /* FALL THROUGH */
2327             case CXt_FORMAT:
2328             case CXt_NULL:
2329                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2330             default:
2331                 if (ix)
2332                     DIE(aTHX_ "panic: goto");
2333                 gotoprobe = PL_main_root;
2334                 break;
2335             }
2336             if (gotoprobe) {
2337                 retop = dofindlabel(gotoprobe, label,
2338                                     enterops, enterops + GOTO_DEPTH);
2339                 if (retop)
2340                     break;
2341             }
2342             PL_lastgotoprobe = gotoprobe;
2343         }
2344         if (!retop)
2345             DIE(aTHX_ "Can't find label %s", label);
2346
2347         /* if we're leaving an eval, check before we pop any frames
2348            that we're not going to punt, otherwise the error
2349            won't be caught */
2350
2351         if (leaving_eval && *enterops && enterops[1]) {
2352             I32 i;
2353             for (i = 1; enterops[i]; i++)
2354                 if (enterops[i]->op_type == OP_ENTERITER)
2355                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2356         }
2357
2358         /* pop unwanted frames */
2359
2360         if (ix < cxstack_ix) {
2361             I32 oldsave;
2362
2363             if (ix < 0)
2364                 ix = 0;
2365             dounwind(ix);
2366             TOPBLOCK(cx);
2367             oldsave = PL_scopestack[PL_scopestack_ix];
2368             LEAVE_SCOPE(oldsave);
2369         }
2370
2371         /* push wanted frames */
2372
2373         if (*enterops && enterops[1]) {
2374             OP *oldop = PL_op;
2375             for (ix = 1; enterops[ix]; ix++) {
2376                 PL_op = enterops[ix];
2377                 /* Eventually we may want to stack the needed arguments
2378                  * for each op.  For now, we punt on the hard ones. */
2379                 if (PL_op->op_type == OP_ENTERITER)
2380                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2381                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2382             }
2383             PL_op = oldop;
2384         }
2385     }
2386
2387     if (do_dump) {
2388 #ifdef VMS
2389         if (!retop) retop = PL_main_start;
2390 #endif
2391         PL_restartop = retop;
2392         PL_do_undump = TRUE;
2393
2394         my_unexec();
2395
2396         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2397         PL_do_undump = FALSE;
2398     }
2399
2400     RETURNOP(retop);
2401 }
2402
2403 PP(pp_exit)
2404 {
2405     dSP;
2406     I32 anum;
2407
2408     if (MAXARG < 1)
2409         anum = 0;
2410     else {
2411         anum = SvIVx(POPs);
2412 #ifdef VMS
2413         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2414             anum = 0;
2415         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2416 #endif
2417     }
2418     PL_exit_flags |= PERL_EXIT_EXPECTED;
2419     my_exit(anum);
2420     PUSHs(&PL_sv_undef);
2421     RETURN;
2422 }
2423
2424 #ifdef NOTYET
2425 PP(pp_nswitch)
2426 {
2427     dSP;
2428     NV value = SvNVx(GvSV(cCOP->cop_gv));
2429     register I32 match = I_32(value);
2430
2431     if (value < 0.0) {
2432         if (((NV)match) > value)
2433             --match;            /* was fractional--truncate other way */
2434     }
2435     match -= cCOP->uop.scop.scop_offset;
2436     if (match < 0)
2437         match = 0;
2438     else if (match > cCOP->uop.scop.scop_max)
2439         match = cCOP->uop.scop.scop_max;
2440     PL_op = cCOP->uop.scop.scop_next[match];
2441     RETURNOP(PL_op);
2442 }
2443
2444 PP(pp_cswitch)
2445 {
2446     dSP;
2447     register I32 match;
2448
2449     if (PL_multiline)
2450         PL_op = PL_op->op_next;                 /* can't assume anything */
2451     else {
2452         STRLEN n_a;
2453         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2454         match -= cCOP->uop.scop.scop_offset;
2455         if (match < 0)
2456             match = 0;
2457         else if (match > cCOP->uop.scop.scop_max)
2458             match = cCOP->uop.scop.scop_max;
2459         PL_op = cCOP->uop.scop.scop_next[match];
2460     }
2461     RETURNOP(PL_op);
2462 }
2463 #endif
2464
2465 /* Eval. */
2466
2467 STATIC void
2468 S_save_lines(pTHX_ AV *array, SV *sv)
2469 {
2470     register char *s = SvPVX(sv);
2471     register char *send = SvPVX(sv) + SvCUR(sv);
2472     register char *t;
2473     register I32 line = 1;
2474
2475     while (s && s < send) {
2476         SV *tmpstr = NEWSV(85,0);
2477
2478         sv_upgrade(tmpstr, SVt_PVMG);
2479         t = strchr(s, '\n');
2480         if (t)
2481             t++;
2482         else
2483             t = send;
2484
2485         sv_setpvn(tmpstr, s, t - s);
2486         av_store(array, line++, tmpstr);
2487         s = t;
2488     }
2489 }
2490
2491 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2492 STATIC void *
2493 S_docatch_body(pTHX_ va_list args)
2494 {
2495     return docatch_body();
2496 }
2497 #endif
2498
2499 STATIC void *
2500 S_docatch_body(pTHX)
2501 {
2502     CALLRUNOPS(aTHX);
2503     return NULL;
2504 }
2505
2506 STATIC OP *
2507 S_docatch(pTHX_ OP *o)
2508 {
2509     int ret;
2510     OP *oldop = PL_op;
2511     OP *retop;
2512     volatile PERL_SI *cursi = PL_curstackinfo;
2513     dJMPENV;
2514
2515 #ifdef DEBUGGING
2516     assert(CATCH_GET == TRUE);
2517 #endif
2518     PL_op = o;
2519
2520     /* Normally, the leavetry at the end of this block of ops will
2521      * pop an op off the return stack and continue there. By setting
2522      * the op to Nullop, we force an exit from the inner runops()
2523      * loop. DAPM.
2524      */
2525     retop = pop_return();
2526     push_return(Nullop);
2527
2528 #ifdef PERL_FLEXIBLE_EXCEPTIONS
2529  redo_body:
2530     CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_docatch_body));
2531 #else
2532     JMPENV_PUSH(ret);
2533 #endif
2534     switch (ret) {
2535     case 0:
2536 #ifndef PERL_FLEXIBLE_EXCEPTIONS
2537  redo_body:
2538         docatch_body();
2539 #endif
2540         break;
2541     case 3:
2542         /* die caught by an inner eval - continue inner loop */
2543         if (PL_restartop && cursi == PL_curstackinfo) {
2544             PL_op = PL_restartop;
2545             PL_restartop = 0;
2546             goto redo_body;
2547         }
2548         /* a die in this eval - continue in outer loop */
2549         if (!PL_restartop)
2550             break;
2551         /* FALL THROUGH */
2552     default:
2553         JMPENV_POP;
2554         PL_op = oldop;
2555         JMPENV_JUMP(ret);
2556         /* NOTREACHED */
2557     }
2558     JMPENV_POP;
2559     PL_op = oldop;
2560     return retop;
2561 }
2562
2563 OP *
2564 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, PAD** padp)
2565 /* sv Text to convert to OP tree. */
2566 /* startop op_free() this to undo. */
2567 /* code Short string id of the caller. */
2568 {
2569     dSP;                                /* Make POPBLOCK work. */
2570     PERL_CONTEXT *cx;
2571     SV **newsp;
2572     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2573     I32 optype;
2574     OP dummy;
2575     OP *rop;
2576     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2577     char *tmpbuf = tbuf;
2578     char *safestr;
2579     int runtime;
2580     CV* runcv;
2581
2582     ENTER;
2583     lex_start(sv);
2584     SAVETMPS;
2585     /* switch to eval mode */
2586
2587     if (PL_curcop == &PL_compiling) {
2588         SAVECOPSTASH_FREE(&PL_compiling);
2589         CopSTASH_set(&PL_compiling, PL_curstash);
2590     }
2591     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2592         SV *sv = sv_newmortal();
2593         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2594                        code, (unsigned long)++PL_evalseq,
2595                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2596         tmpbuf = SvPVX(sv);
2597     }
2598     else
2599         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2600     SAVECOPFILE_FREE(&PL_compiling);
2601     CopFILE_set(&PL_compiling, tmpbuf+2);
2602     SAVECOPLINE(&PL_compiling);
2603     CopLINE_set(&PL_compiling, 1);
2604     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2605        deleting the eval's FILEGV from the stash before gv_check() runs
2606        (i.e. before run-time proper). To work around the coredump that
2607        ensues, we always turn GvMULTI_on for any globals that were
2608        introduced within evals. See force_ident(). GSAR 96-10-12 */
2609     safestr = savepv(tmpbuf);
2610     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2611     SAVEHINTS();
2612 #ifdef OP_IN_REGISTER
2613     PL_opsave = op;
2614 #else
2615     SAVEVPTR(PL_op);
2616 #endif
2617     PL_hints &= HINT_UTF8;
2618
2619     /* we get here either during compilation, or via pp_regcomp at runtime */
2620     runtime = PL_op && (PL_op->op_type == OP_REGCOMP);
2621     if (runtime)
2622         runcv = find_runcv(NULL);
2623
2624     PL_op = &dummy;
2625     PL_op->op_type = OP_ENTEREVAL;
2626     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2627     PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
2628     PUSHEVAL(cx, 0, Nullgv);
2629
2630     if (runtime)
2631         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2632     else
2633         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2634     POPBLOCK(cx,PL_curpm);
2635     POPEVAL(cx);
2636
2637     (*startop)->op_type = OP_NULL;
2638     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2639     lex_end();
2640     /* XXX DAPM do this properly one year */
2641     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2642     LEAVE;
2643     if (PL_curcop == &PL_compiling)
2644         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2645 #ifdef OP_IN_REGISTER
2646     op = PL_opsave;
2647 #endif
2648     return rop;
2649 }
2650
2651
2652 /*
2653 =for apidoc find_runcv
2654
2655 Locate the CV corresponding to the currently executing sub or eval.
2656 If db_seqp is non_null, skip CVs that are in the DB package and populate
2657 *db_seqp with the cop sequence number at the point that the DB:: code was
2658 entered. (allows debuggers to eval in the scope of the breakpoint rather
2659 than in in the scope of the debuger itself).
2660
2661 =cut
2662 */
2663
2664 CV*
2665 Perl_find_runcv(pTHX_ U32 *db_seqp)
2666 {
2667     I32          ix;
2668     PERL_SI      *si;
2669     PERL_CONTEXT *cx;
2670
2671     if (db_seqp)
2672         *db_seqp = PL_curcop->cop_seq;
2673     for (si = PL_curstackinfo; si; si = si->si_prev) {
2674         for (ix = si->si_cxix; ix >= 0; ix--) {
2675             cx = &(si->si_cxstack[ix]);
2676             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2677                 CV *cv = cx->blk_sub.cv;
2678                 /* skip DB:: code */
2679                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2680                     *db_seqp = cx->blk_oldcop->cop_seq;
2681                     continue;
2682                 }
2683                 return cv;
2684             }
2685             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2686                 return PL_compcv;
2687         }
2688     }
2689     return PL_main_cv;
2690 }
2691
2692
2693 /* Compile a require/do, an eval '', or a /(?{...})/.
2694  * In the last case, startop is non-null, and contains the address of
2695  * a pointer that should be set to the just-compiled code.
2696  * outside is the lexically enclosing CV (if any) that invoked us.
2697  */
2698
2699 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2700 STATIC OP *
2701 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2702 {
2703     dSP;
2704     OP *saveop = PL_op;
2705
2706     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2707                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2708                   : EVAL_INEVAL);
2709
2710     PUSHMARK(SP);
2711
2712     SAVESPTR(PL_compcv);
2713     PL_compcv = (CV*)NEWSV(1104,0);
2714     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2715     CvEVAL_on(PL_compcv);
2716     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2717     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2718
2719     CvOUTSIDE_SEQ(PL_compcv) = seq;
2720     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2721
2722     /* set up a scratch pad */
2723
2724     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2725
2726
2727     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2728
2729     /* make sure we compile in the right package */
2730
2731     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2732         SAVESPTR(PL_curstash);
2733         PL_curstash = CopSTASH(PL_curcop);
2734     }
2735     SAVESPTR(PL_beginav);
2736     PL_beginav = newAV();
2737     SAVEFREESV(PL_beginav);
2738     SAVEI32(PL_error_count);
2739
2740     /* try to compile it */
2741
2742     PL_eval_root = Nullop;
2743     PL_error_count = 0;
2744     PL_curcop = &PL_compiling;
2745     PL_curcop->cop_arybase = 0;
2746     if (saveop && saveop->op_flags & OPf_SPECIAL)
2747         PL_in_eval |= EVAL_KEEPERR;
2748     else
2749         sv_setpv(ERRSV,"");
2750     if (yyparse() || PL_error_count || !PL_eval_root) {
2751         SV **newsp;
2752         I32 gimme;
2753         PERL_CONTEXT *cx;
2754         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2755         STRLEN n_a;
2756
2757         PL_op = saveop;
2758         if (PL_eval_root) {
2759             op_free(PL_eval_root);
2760             PL_eval_root = Nullop;
2761         }
2762         SP = PL_stack_base + POPMARK;           /* pop original mark */
2763         if (!startop) {
2764             POPBLOCK(cx,PL_curpm);
2765             POPEVAL(cx);
2766             pop_return();
2767         }
2768         lex_end();
2769         LEAVE;
2770         if (optype == OP_REQUIRE) {
2771             char* msg = SvPVx(ERRSV, n_a);
2772             DIE(aTHX_ "%sCompilation failed in require",
2773                 *msg ? msg : "Unknown error\n");
2774         }
2775         else if (startop) {
2776             char* msg = SvPVx(ERRSV, n_a);
2777
2778             POPBLOCK(cx,PL_curpm);
2779             POPEVAL(cx);
2780             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2781                        (*msg ? msg : "Unknown error\n"));
2782         }
2783         else {
2784             char* msg = SvPVx(ERRSV, n_a);
2785             if (!*msg) {
2786                 sv_setpv(ERRSV, "Compilation error");
2787             }
2788         }
2789         RETPUSHUNDEF;
2790     }
2791     CopLINE_set(&PL_compiling, 0);
2792     if (startop) {
2793         *startop = PL_eval_root;
2794     } else
2795         SAVEFREEOP(PL_eval_root);
2796     if (gimme & G_VOID)
2797         scalarvoid(PL_eval_root);
2798     else if (gimme & G_ARRAY)
2799         list(PL_eval_root);
2800     else
2801         scalar(PL_eval_root);
2802
2803     DEBUG_x(dump_eval());
2804
2805     /* Register with debugger: */
2806     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2807         CV *cv = get_cv("DB::postponed", FALSE);
2808         if (cv) {
2809             dSP;
2810             PUSHMARK(SP);
2811             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2812             PUTBACK;
2813             call_sv((SV*)cv, G_DISCARD);
2814         }
2815     }
2816
2817     /* compiled okay, so do it */
2818
2819     CvDEPTH(PL_compcv) = 1;
2820     SP = PL_stack_base + POPMARK;               /* pop original mark */
2821     PL_op = saveop;                     /* The caller may need it. */
2822     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2823
2824     RETURNOP(PL_eval_start);
2825 }
2826
2827 STATIC PerlIO *
2828 S_doopen_pmc(pTHX_ const char *name, const char *mode)
2829 {
2830     STRLEN namelen = strlen(name);
2831     PerlIO *fp;
2832
2833     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
2834         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
2835         char *pmc = SvPV_nolen(pmcsv);
2836         Stat_t pmstat;
2837         Stat_t pmcstat;
2838         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
2839             fp = PerlIO_open(name, mode);
2840         }
2841         else {
2842             if (PerlLIO_stat(name, &pmstat) < 0 ||
2843                 pmstat.st_mtime < pmcstat.st_mtime)
2844             {
2845                 fp = PerlIO_open(pmc, mode);
2846             }
2847             else {
2848                 fp = PerlIO_open(name, mode);
2849             }
2850         }
2851         SvREFCNT_dec(pmcsv);
2852     }
2853     else {
2854         fp = PerlIO_open(name, mode);
2855     }
2856     return fp;
2857 }
2858
2859 PP(pp_require)
2860 {
2861     dSP;
2862     register PERL_CONTEXT *cx;
2863     SV *sv;
2864     char *name;
2865     STRLEN len;
2866     char *tryname = Nullch;
2867     SV *namesv = Nullsv;
2868     SV** svp;
2869     I32 gimme = GIMME_V;
2870     PerlIO *tryrsfp = 0;
2871     STRLEN n_a;
2872     int filter_has_file = 0;
2873     GV *filter_child_proc = 0;
2874     SV *filter_state = 0;
2875     SV *filter_sub = 0;
2876     SV *hook_sv = 0;
2877     SV *encoding;
2878     OP *op;
2879
2880     sv = POPs;
2881     if (SvNIOKp(sv) && PL_op->op_type != OP_DOFILE) {
2882         if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) {               /* require v5.6.1 */
2883             UV rev = 0, ver = 0, sver = 0;
2884             STRLEN len;
2885             U8 *s = (U8*)SvPVX(sv);
2886             U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
2887             if (s < end) {
2888                 rev = utf8n_to_uvchr(s, end - s, &len, 0);
2889                 s += len;
2890                 if (s < end) {
2891                     ver = utf8n_to_uvchr(s, end - s, &len, 0);
2892                     s += len;
2893                     if (s < end)
2894                         sver = utf8n_to_uvchr(s, end - s, &len, 0);
2895                 }
2896             }
2897             if (PERL_REVISION < rev
2898                 || (PERL_REVISION == rev
2899                     && (PERL_VERSION < ver
2900                         || (PERL_VERSION == ver
2901                             && PERL_SUBVERSION < sver))))
2902             {
2903                 DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
2904                     "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
2905                     PERL_VERSION, PERL_SUBVERSION);
2906             }
2907             if (ckWARN(WARN_PORTABLE))
2908                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
2909                         "v-string in use/require non-portable");
2910             RETPUSHYES;
2911         }
2912         else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
2913             if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
2914                 + ((NV)PERL_SUBVERSION/(NV)1000000)
2915                 + 0.00000099 < SvNV(sv))
2916             {
2917                 NV nrev = SvNV(sv);
2918                 UV rev = (UV)nrev;
2919                 NV nver = (nrev - rev) * 1000;
2920                 UV ver = (UV)(nver + 0.0009);
2921                 NV nsver = (nver - ver) * 1000;
2922                 UV sver = (UV)(nsver + 0.0009);
2923
2924                 /* help out with the "use 5.6" confusion */
2925                 if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
2926                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required"
2927                         " (did you mean v%"UVuf".%03"UVuf"?)--"
2928                         "this is only v%d.%d.%d, stopped",
2929                         rev, ver, sver, rev, ver/100,
2930                         PERL_REVISION, PERL_VERSION, PERL_SUBVERSION);
2931                 }
2932                 else {
2933                     DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
2934                         "this is only v%d.%d.%d, stopped",
2935                         rev, ver, sver, PERL_REVISION, PERL_VERSION,
2936                         PERL_SUBVERSION);
2937                 }
2938             }
2939             RETPUSHYES;
2940         }
2941     }
2942     name = SvPV(sv, len);
2943     if (!(name && len > 0 && *name))
2944         DIE(aTHX_ "Null filename used");
2945     TAINT_PROPER("require");
2946     if (PL_op->op_type == OP_REQUIRE &&
2947       (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0)) &&
2948       *svp != &PL_sv_undef)
2949         RETPUSHYES;
2950
2951     /* prepare to compile file */
2952
2953     if (path_is_absolute(name)) {
2954         tryname = name;
2955         tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
2956     }
2957 #ifdef MACOS_TRADITIONAL
2958     if (!tryrsfp) {
2959         char newname[256];
2960
2961         MacPerl_CanonDir(name, newname, 1);
2962         if (path_is_absolute(newname)) {
2963             tryname = newname;
2964             tryrsfp = doopen_pmc(newname,PERL_SCRIPT_MODE);
2965         }
2966     }
2967 #endif
2968     if (!tryrsfp) {
2969         AV *ar = GvAVn(PL_incgv);
2970         I32 i;
2971 #ifdef VMS
2972         char *unixname;
2973         if ((unixname = tounixspec(name, Nullch)) != Nullch)
2974 #endif
2975         {
2976             namesv = NEWSV(806, 0);
2977             for (i = 0; i <= AvFILL(ar); i++) {
2978                 SV *dirsv = *av_fetch(ar, i, TRUE);
2979
2980                 if (SvROK(dirsv)) {
2981                     int count;
2982                     SV *loader = dirsv;
2983
2984                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
2985                         && !sv_isobject(loader))
2986                     {
2987                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
2988                     }
2989
2990                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
2991                                    PTR2UV(SvRV(dirsv)), name);
2992                     tryname = SvPVX(namesv);
2993                     tryrsfp = 0;
2994
2995                     ENTER;
2996                     SAVETMPS;
2997                     EXTEND(SP, 2);
2998
2999                     PUSHMARK(SP);
3000                     PUSHs(dirsv);
3001                     PUSHs(sv);
3002                     PUTBACK;
3003                     if (sv_isobject(loader))
3004                         count = call_method("INC", G_ARRAY);
3005                     else
3006                         count = call_sv(loader, G_ARRAY);
3007                     SPAGAIN;
3008
3009                     if (count > 0) {
3010                         int i = 0;
3011                         SV *arg;
3012
3013                         SP -= count - 1;
3014                         arg = SP[i++];
3015
3016                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3017                             arg = SvRV(arg);
3018                         }
3019
3020                         if (SvTYPE(arg) == SVt_PVGV) {
3021                             IO *io = GvIO((GV *)arg);
3022
3023                             ++filter_has_file;
3024
3025                             if (io) {
3026                                 tryrsfp = IoIFP(io);
3027                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3028                                     /* reading from a child process doesn't
3029                                        nest -- when returning from reading
3030                                        the inner module, the outer one is
3031                                        unreadable (closed?)  I've tried to
3032                                        save the gv to manage the lifespan of
3033                                        the pipe, but this didn't help. XXX */
3034                                     filter_child_proc = (GV *)arg;
3035                                     (void)SvREFCNT_inc(filter_child_proc);
3036                                 }
3037                                 else {
3038                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3039                                         PerlIO_close(IoOFP(io));
3040                                     }
3041                                     IoIFP(io) = Nullfp;
3042                                     IoOFP(io) = Nullfp;
3043                                 }
3044                             }
3045
3046                             if (i < count) {
3047                                 arg = SP[i++];
3048                             }
3049                         }
3050
3051                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3052                             filter_sub = arg;
3053                             (void)SvREFCNT_inc(filter_sub);
3054
3055                             if (i < count) {
3056                                 filter_state = SP[i];
3057                                 (void)SvREFCNT_inc(filter_state);
3058                             }
3059
3060                             if (tryrsfp == 0) {
3061                                 tryrsfp = PerlIO_open("/dev/null",
3062                                                       PERL_SCRIPT_MODE);
3063                             }
3064                         }
3065                     }
3066
3067                     PUTBACK;
3068                     FREETMPS;
3069                     LEAVE;
3070
3071                     if (tryrsfp) {
3072                         hook_sv = dirsv;
3073                         break;
3074                     }
3075
3076                     filter_has_file = 0;
3077                     if (filter_child_proc) {
3078                         SvREFCNT_dec(filter_child_proc);
3079                         filter_child_proc = 0;
3080                     }
3081                     if (filter_state) {
3082                         SvREFCNT_dec(filter_state);
3083                         filter_state = 0;
3084                     }
3085                     if (filter_sub) {
3086                         SvREFCNT_dec(filter_sub);
3087                         filter_sub = 0;
3088                     }
3089                 }
3090                 else {
3091                   if (!path_is_absolute(name)
3092 #ifdef MACOS_TRADITIONAL
3093                         /* We consider paths of the form :a:b ambiguous and interpret them first
3094                            as global then as local
3095                         */
3096                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3097 #endif
3098                   ) {
3099                     char *dir = SvPVx(dirsv, n_a);
3100 #ifdef MACOS_TRADITIONAL
3101                     char buf1[256];
3102                     char buf2[256];
3103
3104                     MacPerl_CanonDir(name, buf2, 1);
3105                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3106 #else
3107 #ifdef VMS
3108                     char *unixdir;
3109                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3110                         continue;
3111                     sv_setpv(namesv, unixdir);
3112                     sv_catpv(namesv, unixname);
3113 #else
3114                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3115 #endif
3116 #endif
3117                     TAINT_PROPER("require");
3118                     tryname = SvPVX(namesv);
3119                     tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
3120                     if (tryrsfp) {
3121                         if (tryname[0] == '.' && tryname[1] == '/')
3122                             tryname += 2;
3123                         break;
3124                     }
3125                   }
3126                 }
3127             }
3128         }
3129     }
3130     SAVECOPFILE_FREE(&PL_compiling);
3131     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3132     SvREFCNT_dec(namesv);
3133     if (!tryrsfp) {
3134         if (PL_op->op_type == OP_REQUIRE) {
3135             char *msgstr = name;
3136             if (namesv) {                       /* did we lookup @INC? */
3137                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3138                 SV *dirmsgsv = NEWSV(0, 0);
3139                 AV *ar = GvAVn(PL_incgv);
3140                 I32 i;
3141                 sv_catpvn(msg, " in @INC", 8);
3142                 if (instr(SvPVX(msg), ".h "))
3143                     sv_catpv(msg, " (change .h to .ph maybe?)");
3144                 if (instr(SvPVX(msg), ".ph "))
3145                     sv_catpv(msg, " (did you run h2ph?)");
3146                 sv_catpv(msg, " (@INC contains:");
3147                 for (i = 0; i <= AvFILL(ar); i++) {
3148                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3149                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3150                     sv_catsv(msg, dirmsgsv);
3151                 }
3152                 sv_catpvn(msg, ")", 1);
3153                 SvREFCNT_dec(dirmsgsv);
3154                 msgstr = SvPV_nolen(msg);
3155             }
3156             DIE(aTHX_ "Can't locate %s", msgstr);
3157         }
3158
3159         RETPUSHUNDEF;
3160     }
3161     else
3162         SETERRNO(0, SS_NORMAL);
3163
3164     /* Assume success here to prevent recursive requirement. */
3165     len = strlen(name);
3166     /* Check whether a hook in @INC has already filled %INC */
3167     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3168         (void)hv_store(GvHVn(PL_incgv), name, len,
3169                        (hook_sv ? SvREFCNT_inc(hook_sv)
3170                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3171                        0 );
3172     }
3173
3174     ENTER;
3175     SAVETMPS;
3176     lex_start(sv_2mortal(newSVpvn("",0)));
3177     SAVEGENERICSV(PL_rsfp_filters);
3178     PL_rsfp_filters = Nullav;
3179
3180     PL_rsfp = tryrsfp;
3181     SAVEHINTS();
3182     PL_hints = 0;
3183     SAVESPTR(PL_compiling.cop_warnings);
3184     if (PL_dowarn & G_WARN_ALL_ON)
3185         PL_compiling.cop_warnings = pWARN_ALL ;
3186     else if (PL_dowarn & G_WARN_ALL_OFF)
3187         PL_compiling.cop_warnings = pWARN_NONE ;
3188     else if (PL_taint_warn)
3189         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3190     else
3191         PL_compiling.cop_warnings = pWARN_STD ;
3192     SAVESPTR(PL_compiling.cop_io);
3193     PL_compiling.cop_io = Nullsv;
3194
3195     if (filter_sub || filter_child_proc) {
3196         SV *datasv = filter_add(run_user_filter, Nullsv);
3197         IoLINES(datasv) = filter_has_file;
3198         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3199         IoTOP_GV(datasv) = (GV *)filter_state;
3200         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3201     }
3202
3203     /* switch to eval mode */
3204     push_return(PL_op->op_next);
3205     PUSHBLOCK(cx, CXt_EVAL, SP);
3206     PUSHEVAL(cx, name, Nullgv);
3207
3208     SAVECOPLINE(&PL_compiling);
3209     CopLINE_set(&PL_compiling, 0);
3210
3211     PUTBACK;
3212
3213     /* Store and reset encoding. */
3214     encoding = PL_encoding;
3215     PL_encoding = Nullsv;
3216
3217     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3218
3219     /* Restore encoding. */
3220     PL_encoding = encoding;
3221
3222     return op;
3223 }
3224
3225 PP(pp_dofile)
3226 {
3227     return pp_require();
3228 }
3229
3230 PP(pp_entereval)
3231 {
3232     dSP;
3233     register PERL_CONTEXT *cx;
3234     dPOPss;
3235     I32 gimme = GIMME_V, was = PL_sub_generation;
3236     char tbuf[TYPE_DIGITS(long) + 12];
3237     char *tmpbuf = tbuf;
3238     char *safestr;
3239     STRLEN len;
3240     OP *ret;
3241     CV* runcv;
3242     U32 seq;
3243
3244     if (!SvPV(sv,len))
3245         RETPUSHUNDEF;
3246     TAINT_PROPER("eval");
3247
3248     ENTER;
3249     lex_start(sv);
3250     SAVETMPS;
3251
3252     /* switch to eval mode */
3253
3254     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3255         SV *sv = sv_newmortal();
3256         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3257                        (unsigned long)++PL_evalseq,
3258                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3259         tmpbuf = SvPVX(sv);
3260     }
3261     else
3262         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3263     SAVECOPFILE_FREE(&PL_compiling);
3264     CopFILE_set(&PL_compiling, tmpbuf+2);
3265     SAVECOPLINE(&PL_compiling);
3266     CopLINE_set(&PL_compiling, 1);
3267     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3268        deleting the eval's FILEGV from the stash before gv_check() runs
3269        (i.e. before run-time proper). To work around the coredump that
3270        ensues, we always turn GvMULTI_on for any globals that were
3271        introduced within evals. See force_ident(). GSAR 96-10-12 */
3272     safestr = savepv(tmpbuf);
3273     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3274     SAVEHINTS();
3275     PL_hints = PL_op->op_targ;
3276     SAVESPTR(PL_compiling.cop_warnings);
3277     if (specialWARN(PL_curcop->cop_warnings))
3278         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3279     else {
3280         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3281         SAVEFREESV(PL_compiling.cop_warnings);
3282     }
3283     SAVESPTR(PL_compiling.cop_io);
3284     if (specialCopIO(PL_curcop->cop_io))
3285         PL_compiling.cop_io = PL_curcop->cop_io;
3286     else {
3287         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3288         SAVEFREESV(PL_compiling.cop_io);
3289     }
3290     /* special case: an eval '' executed within the DB package gets lexically
3291      * placed in the first non-DB CV rather than the current CV - this
3292      * allows the debugger to execute code, find lexicals etc, in the
3293      * scope of the code being debugged. Passing &seq gets find_runcv
3294      * to do the dirty work for us */
3295     runcv = find_runcv(&seq);
3296
3297     push_return(PL_op->op_next);
3298     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3299     PUSHEVAL(cx, 0, Nullgv);
3300
3301     /* prepare to compile string */
3302
3303     if (PERLDB_LINE && PL_curstash != PL_debstash)
3304         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3305     PUTBACK;
3306     ret = doeval(gimme, NULL, runcv, seq);
3307     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3308         && ret != PL_op->op_next) {     /* Successive compilation. */
3309         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3310     }
3311     return DOCATCH(ret);
3312 }
3313
3314 PP(pp_leaveeval)
3315 {
3316     dSP;
3317     register SV **mark;
3318     SV **newsp;
3319     PMOP *newpm;
3320     I32 gimme;
3321     register PERL_CONTEXT *cx;
3322     OP *retop;
3323     U8 save_flags = PL_op -> op_flags;
3324     I32 optype;
3325
3326     POPBLOCK(cx,newpm);
3327     POPEVAL(cx);
3328     retop = pop_return();
3329
3330     TAINT_NOT;
3331     if (gimme == G_VOID)
3332         MARK = newsp;
3333     else if (gimme == G_SCALAR) {
3334         MARK = newsp + 1;
3335         if (MARK <= SP) {
3336             if (SvFLAGS(TOPs) & SVs_TEMP)
3337                 *MARK = TOPs;
3338             else
3339                 *MARK = sv_mortalcopy(TOPs);
3340         }
3341         else {
3342             MEXTEND(mark,0);
3343             *MARK = &PL_sv_undef;
3344         }
3345         SP = MARK;
3346     }
3347     else {
3348         /* in case LEAVE wipes old return values */
3349         for (mark = newsp + 1; mark <= SP; mark++) {
3350             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3351                 *mark = sv_mortalcopy(*mark);
3352                 TAINT_NOT;      /* Each item is independent */
3353             }
3354         }
3355     }
3356     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3357
3358 #ifdef DEBUGGING
3359     assert(CvDEPTH(PL_compcv) == 1);
3360 #endif
3361     CvDEPTH(PL_compcv) = 0;
3362     lex_end();
3363
3364     if (optype == OP_REQUIRE &&
3365         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3366     {
3367         /* Unassume the success we assumed earlier. */
3368         SV *nsv = cx->blk_eval.old_namesv;
3369         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3370         retop = Perl_die(aTHX_ "%s did not return a true value", SvPVX(nsv));
3371         /* die_where() did LEAVE, or we won't be here */
3372     }
3373     else {
3374         LEAVE;
3375         if (!(save_flags & OPf_SPECIAL))
3376             sv_setpv(ERRSV,"");
3377     }
3378
3379     RETURNOP(retop);
3380 }
3381
3382 PP(pp_entertry)
3383 {
3384     dSP;
3385     register PERL_CONTEXT *cx;
3386     I32 gimme = GIMME_V;
3387
3388     ENTER;
3389     SAVETMPS;
3390
3391     push_return(cLOGOP->op_other->op_next);
3392     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3393     PUSHEVAL(cx, 0, 0);
3394
3395     PL_in_eval = EVAL_INEVAL;
3396     sv_setpv(ERRSV,"");
3397     PUTBACK;
3398     return DOCATCH(PL_op->op_next);
3399 }
3400
3401 PP(pp_leavetry)
3402 {
3403     dSP;
3404     register SV **mark;
3405     SV **newsp;
3406     PMOP *newpm;
3407     OP* retop;
3408     I32 gimme;
3409     register PERL_CONTEXT *cx;
3410     I32 optype;
3411
3412     POPBLOCK(cx,newpm);
3413     POPEVAL(cx);
3414     retop = pop_return();
3415
3416     TAINT_NOT;
3417     if (gimme == G_VOID)
3418         SP = newsp;
3419     else if (gimme == G_SCALAR) {
3420         MARK = newsp + 1;
3421         if (MARK <= SP) {
3422             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3423                 *MARK = TOPs;
3424             else
3425                 *MARK = sv_mortalcopy(TOPs);
3426         }
3427         else {
3428             MEXTEND(mark,0);
3429             *MARK = &PL_sv_undef;
3430         }
3431         SP = MARK;
3432     }
3433     else {
3434         /* in case LEAVE wipes old return values */
3435         for (mark = newsp + 1; mark <= SP; mark++) {
3436             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3437                 *mark = sv_mortalcopy(*mark);
3438                 TAINT_NOT;      /* Each item is independent */
3439             }
3440         }
3441     }
3442     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3443
3444     LEAVE;
3445     sv_setpv(ERRSV,"");
3446     RETURNOP(retop);
3447 }
3448
3449 STATIC void
3450 S_doparseform(pTHX_ SV *sv)
3451 {
3452     STRLEN len;
3453     register char *s = SvPV_force(sv, len);
3454     register char *send = s + len;
3455     register char *base = Nullch;
3456     register I32 skipspaces = 0;
3457     bool noblank   = FALSE;
3458     bool repeat    = FALSE;
3459     bool postspace = FALSE;
3460     U16 *fops;
3461     register U16 *fpc;
3462     U16 *linepc = 0;
3463     register I32 arg;
3464     bool ischop;
3465
3466     if (len == 0)
3467         Perl_croak(aTHX_ "Null picture in formline");
3468
3469     New(804, fops, (send - s)*3+10, U16);    /* Almost certainly too long... */
3470     fpc = fops;
3471
3472     if (s < send) {
3473         linepc = fpc;
3474         *fpc++ = FF_LINEMARK;
3475         noblank = repeat = FALSE;
3476         base = s;
3477     }
3478
3479     while (s <= send) {
3480         switch (*s++) {
3481         default:
3482             skipspaces = 0;
3483             continue;
3484
3485         case '~':
3486             if (*s == '~') {
3487                 repeat = TRUE;
3488                 *s = ' ';
3489             }
3490             noblank = TRUE;
3491             s[-1] = ' ';
3492             /* FALL THROUGH */
3493         case ' ': case '\t':
3494             skipspaces++;
3495             continue;
3496
3497         case '\n': case 0:
3498             arg = s - base;
3499             skipspaces++;
3500             arg -= skipspaces;
3501             if (arg) {
3502                 if (postspace)
3503                     *fpc++ = FF_SPACE;
3504                 *fpc++ = FF_LITERAL;
3505                 *fpc++ = (U16)arg;
3506             }
3507             postspace = FALSE;
3508             if (s <= send)
3509                 skipspaces--;
3510             if (skipspaces) {
3511                 *fpc++ = FF_SKIP;
3512                 *fpc++ = (U16)skipspaces;
3513             }
3514             skipspaces = 0;
3515             if (s <= send)
3516                 *fpc++ = FF_NEWLINE;
3517             if (noblank) {
3518                 *fpc++ = FF_BLANK;
3519                 if (repeat)
3520                     arg = fpc - linepc + 1;
3521                 else
3522                     arg = 0;
3523                 *fpc++ = (U16)arg;
3524             }
3525             if (s < send) {
3526                 linepc = fpc;
3527                 *fpc++ = FF_LINEMARK;
3528                 noblank = repeat = FALSE;
3529                 base = s;
3530             }
3531             else
3532                 s++;
3533             continue;
3534
3535         case '@':
3536         case '^':
3537             ischop = s[-1] == '^';
3538
3539             if (postspace) {
3540                 *fpc++ = FF_SPACE;
3541                 postspace = FALSE;
3542             }
3543             arg = (s - base) - 1;
3544             if (arg) {
3545                 *fpc++ = FF_LITERAL;
3546                 *fpc++ = (U16)arg;
3547             }
3548
3549             base = s - 1;
3550             *fpc++ = FF_FETCH;
3551             if (*s == '*') {
3552                 s++;
3553                 *fpc++ = 0;
3554                 *fpc++ = FF_LINEGLOB;
3555             }
3556             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3557                 arg = ischop ? 512 : 0;
3558                 base = s - 1;
3559                 while (*s == '#')
3560                     s++;
3561                 if (*s == '.') {
3562                     char *f;
3563                     s++;
3564                     f = s;
3565                     while (*s == '#')
3566                         s++;
3567                     arg |= 256 + (s - f);
3568                 }
3569                 *fpc++ = s - base;              /* fieldsize for FETCH */
3570                 *fpc++ = FF_DECIMAL;
3571                 *fpc++ = (U16)arg;
3572             }
3573             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3574                 arg = ischop ? 512 : 0;
3575                 base = s - 1;
3576                 s++;                                /* skip the '0' first */
3577                 while (*s == '#')
3578                     s++;
3579                 if (*s == '.') {
3580                     char *f;
3581                     s++;
3582                     f = s;
3583                     while (*s == '#')
3584                         s++;
3585                     arg |= 256 + (s - f);
3586                 }
3587                 *fpc++ = s - base;                /* fieldsize for FETCH */
3588                 *fpc++ = FF_0DECIMAL;
3589                 *fpc++ = (U16)arg;
3590             }
3591             else {
3592                 I32 prespace = 0;
3593                 bool ismore = FALSE;
3594
3595                 if (*s == '>') {
3596                     while (*++s == '>') ;
3597                     prespace = FF_SPACE;
3598                 }
3599                 else if (*s == '|') {
3600                     while (*++s == '|') ;
3601                     prespace = FF_HALFSPACE;
3602                     postspace = TRUE;
3603                 }
3604                 else {
3605                     if (*s == '<')
3606                         while (*++s == '<') ;
3607                     postspace = TRUE;
3608                 }
3609                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3610                     s += 3;
3611                     ismore = TRUE;
3612                 }
3613                 *fpc++ = s - base;              /* fieldsize for FETCH */
3614
3615                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3616
3617                 if (prespace)
3618                     *fpc++ = (U16)prespace;
3619                 *fpc++ = FF_ITEM;
3620                 if (ismore)
3621                     *fpc++ = FF_MORE;
3622                 if (ischop)
3623                     *fpc++ = FF_CHOP;
3624             }
3625             base = s;
3626             skipspaces = 0;
3627             continue;
3628         }
3629     }
3630     *fpc++ = FF_END;
3631
3632     arg = fpc - fops;
3633     { /* need to jump to the next word */
3634         int z;
3635         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3636         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U16) + 4);
3637         s = SvPVX(sv) + SvCUR(sv) + z;
3638     }
3639     Copy(fops, s, arg, U16);
3640     Safefree(fops);
3641     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3642     SvCOMPILED_on(sv);
3643 }
3644
3645 static I32
3646 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3647 {
3648     SV *datasv = FILTER_DATA(idx);
3649     int filter_has_file = IoLINES(datasv);
3650     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3651     SV *filter_state = (SV *)IoTOP_GV(datasv);
3652     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3653     int len = 0;
3654
3655     /* I was having segfault trouble under Linux 2.2.5 after a
3656        parse error occured.  (Had to hack around it with a test
3657        for PL_error_count == 0.)  Solaris doesn't segfault --
3658        not sure where the trouble is yet.  XXX */
3659
3660     if (filter_has_file) {
3661         len = FILTER_READ(idx+1, buf_sv, maxlen);
3662     }
3663
3664     if (filter_sub && len >= 0) {
3665         dSP;
3666         int count;
3667
3668         ENTER;
3669         SAVE_DEFSV;
3670         SAVETMPS;
3671         EXTEND(SP, 2);
3672
3673         DEFSV = buf_sv;
3674         PUSHMARK(SP);
3675         PUSHs(sv_2mortal(newSViv(maxlen)));
3676         if (filter_state) {
3677             PUSHs(filter_state);
3678         }
3679         PUTBACK;
3680         count = call_sv(filter_sub, G_SCALAR);
3681         SPAGAIN;
3682
3683         if (count > 0) {
3684             SV *out = POPs;
3685             if (SvOK(out)) {
3686                 len = SvIV(out);
3687             }
3688         }
3689
3690         PUTBACK;
3691         FREETMPS;
3692         LEAVE;
3693     }
3694
3695     if (len <= 0) {
3696         IoLINES(datasv) = 0;
3697         if (filter_child_proc) {
3698             SvREFCNT_dec(filter_child_proc);
3699             IoFMT_GV(datasv) = Nullgv;
3700         }
3701         if (filter_state) {
3702             SvREFCNT_dec(filter_state);
3703             IoTOP_GV(datasv) = Nullgv;
3704         }
3705         if (filter_sub) {
3706             SvREFCNT_dec(filter_sub);
3707             IoBOTTOM_GV(datasv) = Nullgv;
3708         }
3709         filter_del(run_user_filter);
3710     }
3711
3712     return len;
3713 }
3714
3715 /* perhaps someone can come up with a better name for
3716    this?  it is not really "absolute", per se ... */
3717 static bool
3718 S_path_is_absolute(pTHX_ char *name)
3719 {
3720     if (PERL_FILE_IS_ABSOLUTE(name)
3721 #ifdef MACOS_TRADITIONAL
3722         || (*name == ':'))
3723 #else
3724         || (*name == '.' && (name[1] == '/' ||
3725                              (name[1] == '.' && name[2] == '/'))))
3726 #endif
3727     {
3728         return TRUE;
3729     }
3730     else
3731         return FALSE;
3732 }