pp_ctl.c

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