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