pp_ctl.c

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