pp_ctl.c

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