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     const 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             const 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 const 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_ const char *message, STRLEN msglen)
1396 {
1397     STRLEN n_a;
1398
1399     if (PL_in_eval) {
1400         I32 cxix;
1401         I32 gimme;
1402         SV **newsp;
1403
1404         if (message) {
1405             if (PL_in_eval & EVAL_KEEPERR) {
1406                 static const char prefix[] = "\t(in cleanup) ";
1407                 SV *err = ERRSV;
1408                 char *e = Nullch;
1409                 if (!SvPOK(err))
1410                     sv_setpv(err,"");
1411                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1412                     e = SvPV(err, n_a);
1413                     e += n_a - msglen;
1414                     if (*e != *message || strNE(e,message))
1415                         e = Nullch;
1416                 }
1417                 if (!e) {
1418                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1419                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1420                     sv_catpvn(err, message, msglen);
1421                     if (ckWARN(WARN_MISC)) {
1422                         STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1423                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1424                     }
1425                 }
1426             }
1427             else {
1428                 sv_setpvn(ERRSV, message, msglen);
1429             }
1430         }
1431
1432         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1433                && PL_curstackinfo->si_prev)
1434         {
1435             dounwind(-1);
1436             POPSTACK;
1437         }
1438
1439         if (cxix >= 0) {
1440             I32 optype;
1441             register PERL_CONTEXT *cx;
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                 const 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     const 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, const char *label, OP **opstack, OP **oplimit)
2189 {
2190     OP *kid = Nullop;
2191     OP **ops = opstack;
2192     static const 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     const char *label = 0;
2249     const bool do_dump = (PL_op->op_type == OP_DUMP);
2250     static const char must_have_label[] = "goto must have label";
2251
2252     if (PL_op->op_flags & OPf_STACKED) {
2253         SV *sv = POPs;
2254         STRLEN n_a;
2255
2256         /* This egregious kludge implements goto &subroutine */
2257         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2258             I32 cxix;
2259             register PERL_CONTEXT *cx;
2260             CV* cv = (CV*)SvRV(sv);
2261             SV** mark;
2262             I32 items = 0;
2263             I32 oldsave;
2264             bool reified = 0;
2265
2266         retry:
2267             if (!CvROOT(cv) && !CvXSUB(cv)) {
2268                 const GV * const gv = CvGV(cv);
2269                 if (gv) {
2270                     GV *autogv;
2271                     SV *tmpstr;
2272                     /* autoloaded stub? */
2273                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2274                         goto retry;
2275                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2276                                           GvNAMELEN(gv), FALSE);
2277                     if (autogv && (cv = GvCV(autogv)))
2278                         goto retry;
2279                     tmpstr = sv_newmortal();
2280                     gv_efullname3(tmpstr, gv, Nullch);
2281                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2282                 }
2283                 DIE(aTHX_ "Goto undefined subroutine");
2284             }
2285
2286             /* First do some returnish stuff. */
2287             (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2288             FREETMPS;
2289             cxix = dopoptosub(cxstack_ix);
2290             if (cxix < 0)
2291                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2292             if (cxix < cxstack_ix)
2293                 dounwind(cxix);
2294             TOPBLOCK(cx);
2295             if (CxREALEVAL(cx))
2296                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2297             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2298                 /* put @_ back onto stack */
2299                 AV* av = cx->blk_sub.argarray;
2300
2301                 items = AvFILLp(av) + 1;
2302                 EXTEND(SP, items+1); /* @_ could have been extended. */
2303                 Copy(AvARRAY(av), SP + 1, items, SV*);
2304                 SvREFCNT_dec(GvAV(PL_defgv));
2305                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2306                 CLEAR_ARGARRAY(av);
2307                 /* abandon @_ if it got reified */
2308                 if (AvREAL(av)) {
2309                     reified = 1;
2310                     SvREFCNT_dec(av);
2311                     av = newAV();
2312                     av_extend(av, items-1);
2313                     AvFLAGS(av) = AVf_REIFY;
2314                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2315                 }
2316             }
2317             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2318                 AV* av;
2319                 av = GvAV(PL_defgv);
2320                 items = AvFILLp(av) + 1;
2321                 EXTEND(SP, items+1); /* @_ could have been extended. */
2322                 Copy(AvARRAY(av), SP + 1, items, SV*);
2323             }
2324             mark = SP;
2325             SP += items;
2326             if (CxTYPE(cx) == CXt_SUB &&
2327                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2328                 SvREFCNT_dec(cx->blk_sub.cv);
2329             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2330             LEAVE_SCOPE(oldsave);
2331
2332             /* Now do some callish stuff. */
2333             SAVETMPS;
2334             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2335             if (CvXSUB(cv)) {
2336                 if (reified) {
2337                     I32 index;
2338                     for (index=0; index<items; index++)
2339                         sv_2mortal(SP[-index]);
2340                 }
2341 #ifdef PERL_XSUB_OLDSTYLE
2342                 if (CvOLDSTYLE(cv)) {
2343                     I32 (*fp3)(int,int,int);
2344                     while (SP > mark) {
2345                         SP[1] = SP[0];
2346                         SP--;
2347                     }
2348                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2349                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2350                                    mark - PL_stack_base + 1,
2351                                    items);
2352                     SP = PL_stack_base + items;
2353                 }
2354                 else
2355 #endif /* PERL_XSUB_OLDSTYLE */
2356                 {
2357                     SV **newsp;
2358                     I32 gimme;
2359
2360                     /* Push a mark for the start of arglist */
2361                     PUSHMARK(mark);
2362                     PUTBACK;
2363                     (void)(*CvXSUB(cv))(aTHX_ cv);
2364                     /* Pop the current context like a decent sub should */
2365                     POPBLOCK(cx, PL_curpm);
2366                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2367                 }
2368                 LEAVE;
2369                 assert(CxTYPE(cx) == CXt_SUB);
2370                 return cx->blk_sub.retop;
2371             }
2372             else {
2373                 AV* padlist = CvPADLIST(cv);
2374                 if (CxTYPE(cx) == CXt_EVAL) {
2375                     PL_in_eval = cx->blk_eval.old_in_eval;
2376                     PL_eval_root = cx->blk_eval.old_eval_root;
2377                     cx->cx_type = CXt_SUB;
2378                     cx->blk_sub.hasargs = 0;
2379                 }
2380                 cx->blk_sub.cv = cv;
2381                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2382
2383                 CvDEPTH(cv)++;
2384                 if (CvDEPTH(cv) < 2)
2385                     (void)SvREFCNT_inc(cv);
2386                 else {
2387                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2388                         sub_crush_depth(cv);
2389                     pad_push(padlist, CvDEPTH(cv));
2390                 }
2391                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2392                 if (cx->blk_sub.hasargs)
2393                 {
2394                     AV* av = (AV*)PAD_SVl(0);
2395                     SV** ary;
2396
2397                     cx->blk_sub.savearray = GvAV(PL_defgv);
2398                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2399                     CX_CURPAD_SAVE(cx->blk_sub);
2400                     cx->blk_sub.argarray = av;
2401
2402                     if (items >= AvMAX(av) + 1) {
2403                         ary = AvALLOC(av);
2404                         if (AvARRAY(av) != ary) {
2405                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2406                             SvPVX(av) = (char*)ary;
2407                         }
2408                         if (items >= AvMAX(av) + 1) {
2409                             AvMAX(av) = items - 1;
2410                             Renew(ary,items+1,SV*);
2411                             AvALLOC(av) = ary;
2412                             SvPVX(av) = (char*)ary;
2413                         }
2414                     }
2415                     ++mark;
2416                     Copy(mark,AvARRAY(av),items,SV*);
2417                     AvFILLp(av) = items - 1;
2418                     assert(!AvREAL(av));
2419                     if (reified) {
2420                         /* transfer 'ownership' of refcnts to new @_ */
2421                         AvREAL_on(av);
2422                         AvREIFY_off(av);
2423                     }
2424                     while (items--) {
2425                         if (*mark)
2426                             SvTEMP_off(*mark);
2427                         mark++;
2428                     }
2429                 }
2430                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2431                     /*
2432                      * We do not care about using sv to call CV;
2433                      * it's for informational purposes only.
2434                      */
2435                     SV *sv = GvSV(PL_DBsub);
2436                     CV *gotocv;
2437
2438                     if (PERLDB_SUB_NN) {
2439                         (void)SvUPGRADE(sv, SVt_PVIV);
2440                         (void)SvIOK_on(sv);
2441                         SAVEIV(SvIVX(sv));
2442                         SvIVX(sv) = PTR2IV(cv); /* Do it the quickest way */
2443                     } else {
2444                         save_item(sv);
2445                         gv_efullname3(sv, CvGV(cv), Nullch);
2446                     }
2447                     if (  PERLDB_GOTO
2448                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2449                         PUSHMARK( PL_stack_sp );
2450                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2451                         PL_stack_sp--;
2452                     }
2453                 }
2454                 RETURNOP(CvSTART(cv));
2455             }
2456         }
2457         else {
2458             label = SvPV(sv,n_a);
2459             if (!(do_dump || *label))
2460                 DIE(aTHX_ must_have_label);
2461         }
2462     }
2463     else if (PL_op->op_flags & OPf_SPECIAL) {
2464         if (! do_dump)
2465             DIE(aTHX_ must_have_label);
2466     }
2467     else
2468         label = cPVOP->op_pv;
2469
2470     if (label && *label) {
2471         OP *gotoprobe = 0;
2472         bool leaving_eval = FALSE;
2473         bool in_block = FALSE;
2474         PERL_CONTEXT *last_eval_cx = 0;
2475
2476         /* find label */
2477
2478         PL_lastgotoprobe = 0;
2479         *enterops = 0;
2480         for (ix = cxstack_ix; ix >= 0; ix--) {
2481             cx = &cxstack[ix];
2482             switch (CxTYPE(cx)) {
2483             case CXt_EVAL:
2484                 leaving_eval = TRUE;
2485                 if (!CxTRYBLOCK(cx)) {
2486                     gotoprobe = (last_eval_cx ?
2487                                 last_eval_cx->blk_eval.old_eval_root :
2488                                 PL_eval_root);
2489                     last_eval_cx = cx;
2490                     break;
2491                 }
2492                 /* else fall through */
2493             case CXt_LOOP:
2494                 gotoprobe = cx->blk_oldcop->op_sibling;
2495                 break;
2496             case CXt_SUBST:
2497                 continue;
2498             case CXt_BLOCK:
2499                 if (ix) {
2500                     gotoprobe = cx->blk_oldcop->op_sibling;
2501                     in_block = TRUE;
2502                 } else
2503                     gotoprobe = PL_main_root;
2504                 break;
2505             case CXt_SUB:
2506                 if (CvDEPTH(cx->blk_sub.cv)) {
2507                     gotoprobe = CvROOT(cx->blk_sub.cv);
2508                     break;
2509                 }
2510                 /* FALL THROUGH */
2511             case CXt_FORMAT:
2512             case CXt_NULL:
2513                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2514             default:
2515                 if (ix)
2516                     DIE(aTHX_ "panic: goto");
2517                 gotoprobe = PL_main_root;
2518                 break;
2519             }
2520             if (gotoprobe) {
2521                 retop = dofindlabel(gotoprobe, label,
2522                                     enterops, enterops + GOTO_DEPTH);
2523                 if (retop)
2524                     break;
2525             }
2526             PL_lastgotoprobe = gotoprobe;
2527         }
2528         if (!retop)
2529             DIE(aTHX_ "Can't find label %s", label);
2530
2531         /* if we're leaving an eval, check before we pop any frames
2532            that we're not going to punt, otherwise the error
2533            won't be caught */
2534
2535         if (leaving_eval && *enterops && enterops[1]) {
2536             I32 i;
2537             for (i = 1; enterops[i]; i++)
2538                 if (enterops[i]->op_type == OP_ENTERITER)
2539                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2540         }
2541
2542         /* pop unwanted frames */
2543
2544         if (ix < cxstack_ix) {
2545             I32 oldsave;
2546
2547             if (ix < 0)
2548                 ix = 0;
2549             dounwind(ix);
2550             TOPBLOCK(cx);
2551             oldsave = PL_scopestack[PL_scopestack_ix];
2552             LEAVE_SCOPE(oldsave);
2553         }
2554
2555         /* push wanted frames */
2556
2557         if (*enterops && enterops[1]) {
2558             OP *oldop = PL_op;
2559             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2560             for (; enterops[ix]; ix++) {
2561                 PL_op = enterops[ix];
2562                 /* Eventually we may want to stack the needed arguments
2563                  * for each op.  For now, we punt on the hard ones. */
2564                 if (PL_op->op_type == OP_ENTERITER)
2565                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2566                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2567             }
2568             PL_op = oldop;
2569         }
2570     }
2571
2572     if (do_dump) {
2573 #ifdef VMS
2574         if (!retop) retop = PL_main_start;
2575 #endif
2576         PL_restartop = retop;
2577         PL_do_undump = TRUE;
2578
2579         my_unexec();
2580
2581         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2582         PL_do_undump = FALSE;
2583     }
2584
2585     RETURNOP(retop);
2586 }
2587
2588 PP(pp_exit)
2589 {
2590     dSP;
2591     I32 anum;
2592
2593     if (MAXARG < 1)
2594         anum = 0;
2595     else {
2596         anum = SvIVx(POPs);
2597 #ifdef VMS
2598         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2599             anum = 0;
2600         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2601 #endif
2602     }
2603     PL_exit_flags |= PERL_EXIT_EXPECTED;
2604     my_exit(anum);
2605     PUSHs(&PL_sv_undef);
2606     RETURN;
2607 }
2608
2609 #ifdef NOTYET
2610 PP(pp_nswitch)
2611 {
2612     dSP;
2613     NV value = SvNVx(GvSV(cCOP->cop_gv));
2614     register I32 match = I_32(value);
2615
2616     if (value < 0.0) {
2617         if (((NV)match) > value)
2618             --match;            /* was fractional--truncate other way */
2619     }
2620     match -= cCOP->uop.scop.scop_offset;
2621     if (match < 0)
2622         match = 0;
2623     else if (match > cCOP->uop.scop.scop_max)
2624         match = cCOP->uop.scop.scop_max;
2625     PL_op = cCOP->uop.scop.scop_next[match];
2626     RETURNOP(PL_op);
2627 }
2628
2629 PP(pp_cswitch)
2630 {
2631     dSP;
2632     register I32 match;
2633
2634     if (PL_multiline)
2635         PL_op = PL_op->op_next;                 /* can't assume anything */
2636     else {
2637         STRLEN n_a;
2638         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2639         match -= cCOP->uop.scop.scop_offset;
2640         if (match < 0)
2641             match = 0;
2642         else if (match > cCOP->uop.scop.scop_max)
2643             match = cCOP->uop.scop.scop_max;
2644         PL_op = cCOP->uop.scop.scop_next[match];
2645     }
2646     RETURNOP(PL_op);
2647 }
2648 #endif
2649
2650 /* Eval. */
2651
2652 STATIC void
2653 S_save_lines(pTHX_ AV *array, SV *sv)
2654 {
2655     register char *s = SvPVX(sv);
2656     register char *send = SvPVX(sv) + SvCUR(sv);
2657     register char *t;
2658     register I32 line = 1;
2659
2660     while (s && s < send) {
2661         SV *tmpstr = NEWSV(85,0);
2662
2663         sv_upgrade(tmpstr, SVt_PVMG);
2664         t = strchr(s, '\n');
2665         if (t)
2666             t++;
2667         else
2668             t = send;
2669
2670         sv_setpvn(tmpstr, s, t - s);
2671         av_store(array, line++, tmpstr);
2672         s = t;
2673     }
2674 }
2675
2676 STATIC void *
2677 S_docatch_body(pTHX)
2678 {
2679     CALLRUNOPS(aTHX);
2680     return NULL;
2681 }
2682
2683 STATIC OP *
2684 S_docatch(pTHX_ OP *o)
2685 {
2686     int ret;
2687     OP *oldop = PL_op;
2688     OP *retop;
2689     volatile PERL_SI *cursi = PL_curstackinfo;
2690     dJMPENV;
2691
2692 #ifdef DEBUGGING
2693     assert(CATCH_GET == TRUE);
2694 #endif
2695     PL_op = o;
2696
2697     /* Normally, the leavetry at the end of this block of ops will
2698      * pop an op off the return stack and continue there. By setting
2699      * the op to Nullop, we force an exit from the inner runops()
2700      * loop. DAPM.
2701      */
2702     assert(cxstack_ix >= 0);
2703     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2704     retop = cxstack[cxstack_ix].blk_eval.retop;
2705     cxstack[cxstack_ix].blk_eval.retop = Nullop;
2706
2707     JMPENV_PUSH(ret);
2708     switch (ret) {
2709     case 0:
2710  redo_body:
2711         docatch_body();
2712         break;
2713     case 3:
2714         /* die caught by an inner eval - continue inner loop */
2715         if (PL_restartop && cursi == PL_curstackinfo) {
2716             PL_op = PL_restartop;
2717             PL_restartop = 0;
2718             goto redo_body;
2719         }
2720         /* a die in this eval - continue in outer loop */
2721         if (!PL_restartop)
2722             break;
2723         /* FALL THROUGH */
2724     default:
2725         JMPENV_POP;
2726         PL_op = oldop;
2727         JMPENV_JUMP(ret);
2728         /* NOTREACHED */
2729     }
2730     JMPENV_POP;
2731     PL_op = oldop;
2732     return retop;
2733 }
2734
2735 OP *
2736 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2737 /* sv Text to convert to OP tree. */
2738 /* startop op_free() this to undo. */
2739 /* code Short string id of the caller. */
2740 {
2741     dSP;                                /* Make POPBLOCK work. */
2742     PERL_CONTEXT *cx;
2743     SV **newsp;
2744     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2745     I32 optype;
2746     OP dummy;
2747     OP *rop;
2748     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2749     char *tmpbuf = tbuf;
2750     char *safestr;
2751     int runtime;
2752     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2753
2754     ENTER;
2755     lex_start(sv);
2756     SAVETMPS;
2757     /* switch to eval mode */
2758
2759     if (IN_PERL_COMPILETIME) {
2760         SAVECOPSTASH_FREE(&PL_compiling);
2761         CopSTASH_set(&PL_compiling, PL_curstash);
2762     }
2763     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2764         SV *sv = sv_newmortal();
2765         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2766                        code, (unsigned long)++PL_evalseq,
2767                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2768         tmpbuf = SvPVX(sv);
2769     }
2770     else
2771         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2772     SAVECOPFILE_FREE(&PL_compiling);
2773     CopFILE_set(&PL_compiling, tmpbuf+2);
2774     SAVECOPLINE(&PL_compiling);
2775     CopLINE_set(&PL_compiling, 1);
2776     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2777        deleting the eval's FILEGV from the stash before gv_check() runs
2778        (i.e. before run-time proper). To work around the coredump that
2779        ensues, we always turn GvMULTI_on for any globals that were
2780        introduced within evals. See force_ident(). GSAR 96-10-12 */
2781     safestr = savepv(tmpbuf);
2782     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2783     SAVEHINTS();
2784 #ifdef OP_IN_REGISTER
2785     PL_opsave = op;
2786 #else
2787     SAVEVPTR(PL_op);
2788 #endif
2789
2790     /* we get here either during compilation, or via pp_regcomp at runtime */
2791     runtime = IN_PERL_RUNTIME;
2792     if (runtime)
2793         runcv = find_runcv(NULL);
2794
2795     PL_op = &dummy;
2796     PL_op->op_type = OP_ENTEREVAL;
2797     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2798     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2799     PUSHEVAL(cx, 0, Nullgv);
2800
2801     if (runtime)
2802         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2803     else
2804         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2805     POPBLOCK(cx,PL_curpm);
2806     POPEVAL(cx);
2807
2808     (*startop)->op_type = OP_NULL;
2809     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2810     lex_end();
2811     /* XXX DAPM do this properly one year */
2812     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2813     LEAVE;
2814     if (IN_PERL_COMPILETIME)
2815         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2816 #ifdef OP_IN_REGISTER
2817     op = PL_opsave;
2818 #endif
2819     return rop;
2820 }
2821
2822
2823 /*
2824 =for apidoc find_runcv
2825
2826 Locate the CV corresponding to the currently executing sub or eval.
2827 If db_seqp is non_null, skip CVs that are in the DB package and populate
2828 *db_seqp with the cop sequence number at the point that the DB:: code was
2829 entered. (allows debuggers to eval in the scope of the breakpoint rather
2830 than in in the scope of the debugger itself).
2831
2832 =cut
2833 */
2834
2835 CV*
2836 Perl_find_runcv(pTHX_ U32 *db_seqp)
2837 {
2838     I32          ix;
2839     PERL_SI      *si;
2840     PERL_CONTEXT *cx;
2841
2842     if (db_seqp)
2843         *db_seqp = PL_curcop->cop_seq;
2844     for (si = PL_curstackinfo; si; si = si->si_prev) {
2845         for (ix = si->si_cxix; ix >= 0; ix--) {
2846             cx = &(si->si_cxstack[ix]);
2847             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2848                 CV *cv = cx->blk_sub.cv;
2849                 /* skip DB:: code */
2850                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2851                     *db_seqp = cx->blk_oldcop->cop_seq;
2852                     continue;
2853                 }
2854                 return cv;
2855             }
2856             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2857                 return PL_compcv;
2858         }
2859     }
2860     return PL_main_cv;
2861 }
2862
2863
2864 /* Compile a require/do, an eval '', or a /(?{...})/.
2865  * In the last case, startop is non-null, and contains the address of
2866  * a pointer that should be set to the just-compiled code.
2867  * outside is the lexically enclosing CV (if any) that invoked us.
2868  */
2869
2870 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2871 STATIC OP *
2872 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2873 {
2874     dSP;
2875     OP *saveop = PL_op;
2876
2877     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2878                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2879                   : EVAL_INEVAL);
2880
2881     PUSHMARK(SP);
2882
2883     SAVESPTR(PL_compcv);
2884     PL_compcv = (CV*)NEWSV(1104,0);
2885     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2886     CvEVAL_on(PL_compcv);
2887     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2888     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2889
2890     CvOUTSIDE_SEQ(PL_compcv) = seq;
2891     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2892
2893     /* set up a scratch pad */
2894
2895     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2896
2897
2898     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2899
2900     /* make sure we compile in the right package */
2901
2902     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2903         SAVESPTR(PL_curstash);
2904         PL_curstash = CopSTASH(PL_curcop);
2905     }
2906     SAVESPTR(PL_beginav);
2907     PL_beginav = newAV();
2908     SAVEFREESV(PL_beginav);
2909     SAVEI32(PL_error_count);
2910
2911     /* try to compile it */
2912
2913     PL_eval_root = Nullop;
2914     PL_error_count = 0;
2915     PL_curcop = &PL_compiling;
2916     PL_curcop->cop_arybase = 0;
2917     if (saveop && saveop->op_flags & OPf_SPECIAL)
2918         PL_in_eval |= EVAL_KEEPERR;
2919     else
2920         sv_setpv(ERRSV,"");
2921     if (yyparse() || PL_error_count || !PL_eval_root) {
2922         SV **newsp;                     /* Used by POPBLOCK. */
2923        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2924         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2925         STRLEN n_a;
2926
2927         PL_op = saveop;
2928         if (PL_eval_root) {
2929             op_free(PL_eval_root);
2930             PL_eval_root = Nullop;
2931         }
2932         SP = PL_stack_base + POPMARK;           /* pop original mark */
2933         if (!startop) {
2934             POPBLOCK(cx,PL_curpm);
2935             POPEVAL(cx);
2936         }
2937         lex_end();
2938         LEAVE;
2939         if (optype == OP_REQUIRE) {
2940             char* msg = SvPVx(ERRSV, n_a);
2941            SV *nsv = cx->blk_eval.old_namesv;
2942            (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2943                           &PL_sv_undef, 0);
2944             DIE(aTHX_ "%sCompilation failed in require",
2945                 *msg ? msg : "Unknown error\n");
2946         }
2947         else if (startop) {
2948             char* msg = SvPVx(ERRSV, n_a);
2949
2950             POPBLOCK(cx,PL_curpm);
2951             POPEVAL(cx);
2952             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2953                        (*msg ? msg : "Unknown error\n"));
2954         }
2955         else {
2956             char* msg = SvPVx(ERRSV, n_a);
2957             if (!*msg) {
2958                 sv_setpv(ERRSV, "Compilation error");
2959             }
2960         }
2961         RETPUSHUNDEF;
2962     }
2963     CopLINE_set(&PL_compiling, 0);
2964     if (startop) {
2965         *startop = PL_eval_root;
2966     } else
2967         SAVEFREEOP(PL_eval_root);
2968
2969     /* Set the context for this new optree.
2970      * If the last op is an OP_REQUIRE, force scalar context.
2971      * Otherwise, propagate the context from the eval(). */
2972     if (PL_eval_root->op_type == OP_LEAVEEVAL
2973             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2974             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2975             == OP_REQUIRE)
2976         scalar(PL_eval_root);
2977     else if (gimme & G_VOID)
2978         scalarvoid(PL_eval_root);
2979     else if (gimme & G_ARRAY)
2980         list(PL_eval_root);
2981     else
2982         scalar(PL_eval_root);
2983
2984     DEBUG_x(dump_eval());
2985
2986     /* Register with debugger: */
2987     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2988         CV *cv = get_cv("DB::postponed", FALSE);
2989         if (cv) {
2990             dSP;
2991             PUSHMARK(SP);
2992             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2993             PUTBACK;
2994             call_sv((SV*)cv, G_DISCARD);
2995         }
2996     }
2997
2998     /* compiled okay, so do it */
2999
3000     CvDEPTH(PL_compcv) = 1;
3001     SP = PL_stack_base + POPMARK;               /* pop original mark */
3002     PL_op = saveop;                     /* The caller may need it. */
3003     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3004
3005     RETURNOP(PL_eval_start);
3006 }
3007
3008 STATIC PerlIO *
3009 S_doopen_pm(pTHX_ const char *name, const char *mode)
3010 {
3011 #ifndef PERL_DISABLE_PMC
3012     STRLEN namelen = strlen(name);
3013     PerlIO *fp;
3014
3015     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3016         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3017         char *pmc = SvPV_nolen(pmcsv);
3018         Stat_t pmstat;
3019         Stat_t pmcstat;
3020         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3021             fp = PerlIO_open(name, mode);
3022         }
3023         else {
3024             if (PerlLIO_stat(name, &pmstat) < 0 ||
3025                 pmstat.st_mtime < pmcstat.st_mtime)
3026             {
3027                 fp = PerlIO_open(pmc, mode);
3028             }
3029             else {
3030                 fp = PerlIO_open(name, mode);
3031             }
3032         }
3033         SvREFCNT_dec(pmcsv);
3034     }
3035     else {
3036         fp = PerlIO_open(name, mode);
3037     }
3038     return fp;
3039 #else
3040     return PerlIO_open(name, mode);
3041 #endif /* !PERL_DISABLE_PMC */
3042 }
3043
3044 PP(pp_require)
3045 {
3046     dSP;
3047     register PERL_CONTEXT *cx;
3048     SV *sv;
3049     char *name;
3050     STRLEN len;
3051     char *tryname = Nullch;
3052     SV *namesv = Nullsv;
3053     SV** svp;
3054     I32 gimme = GIMME_V;
3055     PerlIO *tryrsfp = 0;
3056     STRLEN n_a;
3057     int filter_has_file = 0;
3058     GV *filter_child_proc = 0;
3059     SV *filter_state = 0;
3060     SV *filter_sub = 0;
3061     SV *hook_sv = 0;
3062     SV *encoding;
3063     OP *op;
3064
3065     sv = POPs;
3066     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3067         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )       /* require v5.6.1 */
3068                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3069                         "v-string in use/require non-portable");
3070
3071         sv = new_version(sv);
3072         if (!sv_derived_from(PL_patchlevel, "version"))
3073             (void *)upg_version(PL_patchlevel);
3074         if ( vcmp(sv,PL_patchlevel) > 0 )
3075             DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3076                 vstringify(sv), vstringify(PL_patchlevel));
3077
3078             RETPUSHYES;
3079     }
3080     name = SvPV(sv, len);
3081     if (!(name && len > 0 && *name))
3082         DIE(aTHX_ "Null filename used");
3083     TAINT_PROPER("require");
3084     if (PL_op->op_type == OP_REQUIRE &&
3085        (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3086        if (*svp != &PL_sv_undef)
3087            RETPUSHYES;
3088        else
3089            DIE(aTHX_ "Compilation failed in require");
3090     }
3091
3092     /* prepare to compile file */
3093
3094     if (path_is_absolute(name)) {
3095         tryname = name;
3096         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3097     }
3098 #ifdef MACOS_TRADITIONAL
3099     if (!tryrsfp) {
3100         char newname[256];
3101
3102         MacPerl_CanonDir(name, newname, 1);
3103         if (path_is_absolute(newname)) {
3104             tryname = newname;
3105             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3106         }
3107     }
3108 #endif
3109     if (!tryrsfp) {
3110         AV *ar = GvAVn(PL_incgv);
3111         I32 i;
3112 #ifdef VMS
3113         char *unixname;
3114         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3115 #endif
3116         {
3117             namesv = NEWSV(806, 0);
3118             for (i = 0; i <= AvFILL(ar); i++) {
3119                 SV *dirsv = *av_fetch(ar, i, TRUE);
3120
3121                 if (SvROK(dirsv)) {
3122                     int count;
3123                     SV *loader = dirsv;
3124
3125                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3126                         && !sv_isobject(loader))
3127                     {
3128                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3129                     }
3130
3131                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3132                                    PTR2UV(SvRV(dirsv)), name);
3133                     tryname = SvPVX(namesv);
3134                     tryrsfp = 0;
3135
3136                     ENTER;
3137                     SAVETMPS;
3138                     EXTEND(SP, 2);
3139
3140                     PUSHMARK(SP);
3141                     PUSHs(dirsv);
3142                     PUSHs(sv);
3143                     PUTBACK;
3144                     if (sv_isobject(loader))
3145                         count = call_method("INC", G_ARRAY);
3146                     else
3147                         count = call_sv(loader, G_ARRAY);
3148                     SPAGAIN;
3149
3150                     if (count > 0) {
3151                         int i = 0;
3152                         SV *arg;
3153
3154                         SP -= count - 1;
3155                         arg = SP[i++];
3156
3157                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3158                             arg = SvRV(arg);
3159                         }
3160
3161                         if (SvTYPE(arg) == SVt_PVGV) {
3162                             IO *io = GvIO((GV *)arg);
3163
3164                             ++filter_has_file;
3165
3166                             if (io) {
3167                                 tryrsfp = IoIFP(io);
3168                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3169                                     /* reading from a child process doesn't
3170                                        nest -- when returning from reading
3171                                        the inner module, the outer one is
3172                                        unreadable (closed?)  I've tried to
3173                                        save the gv to manage the lifespan of
3174                                        the pipe, but this didn't help. XXX */
3175                                     filter_child_proc = (GV *)arg;
3176                                     (void)SvREFCNT_inc(filter_child_proc);
3177                                 }
3178                                 else {
3179                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3180                                         PerlIO_close(IoOFP(io));
3181                                     }
3182                                     IoIFP(io) = Nullfp;
3183                                     IoOFP(io) = Nullfp;
3184                                 }
3185                             }
3186
3187                             if (i < count) {
3188                                 arg = SP[i++];
3189                             }
3190                         }
3191
3192                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3193                             filter_sub = arg;
3194                             (void)SvREFCNT_inc(filter_sub);
3195
3196                             if (i < count) {
3197                                 filter_state = SP[i];
3198                                 (void)SvREFCNT_inc(filter_state);
3199                             }
3200
3201                             if (tryrsfp == 0) {
3202                                 tryrsfp = PerlIO_open("/dev/null",
3203                                                       PERL_SCRIPT_MODE);
3204                             }
3205                         }
3206                         SP--;
3207                     }
3208
3209                     PUTBACK;
3210                     FREETMPS;
3211                     LEAVE;
3212
3213                     if (tryrsfp) {
3214                         hook_sv = dirsv;
3215                         break;
3216                     }
3217
3218                     filter_has_file = 0;
3219                     if (filter_child_proc) {
3220                         SvREFCNT_dec(filter_child_proc);
3221                         filter_child_proc = 0;
3222                     }
3223                     if (filter_state) {
3224                         SvREFCNT_dec(filter_state);
3225                         filter_state = 0;
3226                     }
3227                     if (filter_sub) {
3228                         SvREFCNT_dec(filter_sub);
3229                         filter_sub = 0;
3230                     }
3231                 }
3232                 else {
3233                   if (!path_is_absolute(name)
3234 #ifdef MACOS_TRADITIONAL
3235                         /* We consider paths of the form :a:b ambiguous and interpret them first
3236                            as global then as local
3237                         */
3238                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3239 #endif
3240                   ) {
3241                     char *dir = SvPVx(dirsv, n_a);
3242 #ifdef MACOS_TRADITIONAL
3243                     char buf1[256];
3244                     char buf2[256];
3245
3246                     MacPerl_CanonDir(name, buf2, 1);
3247                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3248 #else
3249 #ifdef VMS
3250                     char *unixdir;
3251                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3252                         continue;
3253                     sv_setpv(namesv, unixdir);
3254                     sv_catpv(namesv, unixname);
3255 #else
3256                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3257 #endif
3258 #endif
3259                     TAINT_PROPER("require");
3260                     tryname = SvPVX(namesv);
3261                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3262                     if (tryrsfp) {
3263                         if (tryname[0] == '.' && tryname[1] == '/')
3264                             tryname += 2;
3265                         break;
3266                     }
3267                   }
3268                 }
3269             }
3270         }
3271     }
3272     SAVECOPFILE_FREE(&PL_compiling);
3273     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3274     SvREFCNT_dec(namesv);
3275     if (!tryrsfp) {
3276         if (PL_op->op_type == OP_REQUIRE) {
3277             char *msgstr = name;
3278             if (namesv) {                       /* did we lookup @INC? */
3279                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3280                 SV *dirmsgsv = NEWSV(0, 0);
3281                 AV *ar = GvAVn(PL_incgv);
3282                 I32 i;
3283                 sv_catpvn(msg, " in @INC", 8);
3284                 if (instr(SvPVX(msg), ".h "))
3285                     sv_catpv(msg, " (change .h to .ph maybe?)");
3286                 if (instr(SvPVX(msg), ".ph "))
3287                     sv_catpv(msg, " (did you run h2ph?)");
3288                 sv_catpv(msg, " (@INC contains:");
3289                 for (i = 0; i <= AvFILL(ar); i++) {
3290                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3291                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3292                     sv_catsv(msg, dirmsgsv);
3293                 }
3294                 sv_catpvn(msg, ")", 1);
3295                 SvREFCNT_dec(dirmsgsv);
3296                 msgstr = SvPV_nolen(msg);
3297             }
3298             DIE(aTHX_ "Can't locate %s", msgstr);
3299         }
3300
3301         RETPUSHUNDEF;
3302     }
3303     else
3304         SETERRNO(0, SS_NORMAL);
3305
3306     /* Assume success here to prevent recursive requirement. */
3307     len = strlen(name);
3308     /* Check whether a hook in @INC has already filled %INC */
3309     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3310         (void)hv_store(GvHVn(PL_incgv), name, len,
3311                        (hook_sv ? SvREFCNT_inc(hook_sv)
3312                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3313                        0 );
3314     }
3315
3316     ENTER;
3317     SAVETMPS;
3318     lex_start(sv_2mortal(newSVpvn("",0)));
3319     SAVEGENERICSV(PL_rsfp_filters);
3320     PL_rsfp_filters = Nullav;
3321
3322     PL_rsfp = tryrsfp;
3323     SAVEHINTS();
3324     PL_hints = 0;
3325     SAVESPTR(PL_compiling.cop_warnings);
3326     if (PL_dowarn & G_WARN_ALL_ON)
3327         PL_compiling.cop_warnings = pWARN_ALL ;
3328     else if (PL_dowarn & G_WARN_ALL_OFF)
3329         PL_compiling.cop_warnings = pWARN_NONE ;
3330     else if (PL_taint_warn)
3331         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3332     else
3333         PL_compiling.cop_warnings = pWARN_STD ;
3334     SAVESPTR(PL_compiling.cop_io);
3335     PL_compiling.cop_io = Nullsv;
3336
3337     if (filter_sub || filter_child_proc) {
3338         SV *datasv = filter_add(run_user_filter, Nullsv);
3339         IoLINES(datasv) = filter_has_file;
3340         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3341         IoTOP_GV(datasv) = (GV *)filter_state;
3342         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3343     }
3344
3345     /* switch to eval mode */
3346     PUSHBLOCK(cx, CXt_EVAL, SP);
3347     PUSHEVAL(cx, name, Nullgv);
3348     cx->blk_eval.retop = PL_op->op_next;
3349
3350     SAVECOPLINE(&PL_compiling);
3351     CopLINE_set(&PL_compiling, 0);
3352
3353     PUTBACK;
3354
3355     /* Store and reset encoding. */
3356     encoding = PL_encoding;
3357     PL_encoding = Nullsv;
3358
3359     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3360
3361     /* Restore encoding. */
3362     PL_encoding = encoding;
3363
3364     return op;
3365 }
3366
3367 PP(pp_dofile)
3368 {
3369     return pp_require();
3370 }
3371
3372 PP(pp_entereval)
3373 {
3374     dSP;
3375     register PERL_CONTEXT *cx;
3376     dPOPss;
3377     I32 gimme = GIMME_V, was = PL_sub_generation;
3378     char tbuf[TYPE_DIGITS(long) + 12];
3379     char *tmpbuf = tbuf;
3380     char *safestr;
3381     STRLEN len;
3382     OP *ret;
3383     CV* runcv;
3384     U32 seq;
3385
3386     if (!SvPV(sv,len))
3387         RETPUSHUNDEF;
3388     TAINT_PROPER("eval");
3389
3390     ENTER;
3391     lex_start(sv);
3392     SAVETMPS;
3393
3394     /* switch to eval mode */
3395
3396     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3397         SV *sv = sv_newmortal();
3398         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3399                        (unsigned long)++PL_evalseq,
3400                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3401         tmpbuf = SvPVX(sv);
3402     }
3403     else
3404         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3405     SAVECOPFILE_FREE(&PL_compiling);
3406     CopFILE_set(&PL_compiling, tmpbuf+2);
3407     SAVECOPLINE(&PL_compiling);
3408     CopLINE_set(&PL_compiling, 1);
3409     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3410        deleting the eval's FILEGV from the stash before gv_check() runs
3411        (i.e. before run-time proper). To work around the coredump that
3412        ensues, we always turn GvMULTI_on for any globals that were
3413        introduced within evals. See force_ident(). GSAR 96-10-12 */
3414     safestr = savepv(tmpbuf);
3415     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3416     SAVEHINTS();
3417     PL_hints = PL_op->op_targ;
3418     SAVESPTR(PL_compiling.cop_warnings);
3419     if (specialWARN(PL_curcop->cop_warnings))
3420         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3421     else {
3422         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3423         SAVEFREESV(PL_compiling.cop_warnings);
3424     }
3425     SAVESPTR(PL_compiling.cop_io);
3426     if (specialCopIO(PL_curcop->cop_io))
3427         PL_compiling.cop_io = PL_curcop->cop_io;
3428     else {
3429         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3430         SAVEFREESV(PL_compiling.cop_io);
3431     }
3432     /* special case: an eval '' executed within the DB package gets lexically
3433      * placed in the first non-DB CV rather than the current CV - this
3434      * allows the debugger to execute code, find lexicals etc, in the
3435      * scope of the code being debugged. Passing &seq gets find_runcv
3436      * to do the dirty work for us */
3437     runcv = find_runcv(&seq);
3438
3439     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3440     PUSHEVAL(cx, 0, Nullgv);
3441     cx->blk_eval.retop = PL_op->op_next;
3442
3443     /* prepare to compile string */
3444
3445     if (PERLDB_LINE && PL_curstash != PL_debstash)
3446         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3447     PUTBACK;
3448     ret = doeval(gimme, NULL, runcv, seq);
3449     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3450         && ret != PL_op->op_next) {     /* Successive compilation. */
3451         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3452     }
3453     return DOCATCH(ret);
3454 }
3455
3456 PP(pp_leaveeval)
3457 {
3458     dSP;
3459     register SV **mark;
3460     SV **newsp;
3461     PMOP *newpm;
3462     I32 gimme;
3463     register PERL_CONTEXT *cx;
3464     OP *retop;
3465     U8 save_flags = PL_op -> op_flags;
3466     I32 optype;
3467
3468     POPBLOCK(cx,newpm);
3469     POPEVAL(cx);
3470     retop = cx->blk_eval.retop;
3471
3472     TAINT_NOT;
3473     if (gimme == G_VOID)
3474         MARK = newsp;
3475     else if (gimme == G_SCALAR) {
3476         MARK = newsp + 1;
3477         if (MARK <= SP) {
3478             if (SvFLAGS(TOPs) & SVs_TEMP)
3479                 *MARK = TOPs;
3480             else
3481                 *MARK = sv_mortalcopy(TOPs);
3482         }
3483         else {
3484             MEXTEND(mark,0);
3485             *MARK = &PL_sv_undef;
3486         }
3487         SP = MARK;
3488     }
3489     else {
3490         /* in case LEAVE wipes old return values */
3491         for (mark = newsp + 1; mark <= SP; mark++) {
3492             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3493                 *mark = sv_mortalcopy(*mark);
3494                 TAINT_NOT;      /* Each item is independent */
3495             }
3496         }
3497     }
3498     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3499
3500 #ifdef DEBUGGING
3501     assert(CvDEPTH(PL_compcv) == 1);
3502 #endif
3503     CvDEPTH(PL_compcv) = 0;
3504     lex_end();
3505
3506     if (optype == OP_REQUIRE &&
3507         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3508     {
3509         /* Unassume the success we assumed earlier. */
3510         SV *nsv = cx->blk_eval.old_namesv;
3511         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3512         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3513         /* die_where() did LEAVE, or we won't be here */
3514     }
3515     else {
3516         LEAVE;
3517         if (!(save_flags & OPf_SPECIAL))
3518             sv_setpv(ERRSV,"");
3519     }
3520
3521     RETURNOP(retop);
3522 }
3523
3524 PP(pp_entertry)
3525 {
3526     dSP;
3527     register PERL_CONTEXT *cx;
3528     I32 gimme = GIMME_V;
3529
3530     ENTER;
3531     SAVETMPS;
3532
3533     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3534     PUSHEVAL(cx, 0, 0);
3535     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3536
3537     PL_in_eval = EVAL_INEVAL;
3538     sv_setpv(ERRSV,"");
3539     PUTBACK;
3540     return DOCATCH(PL_op->op_next);
3541 }
3542
3543 PP(pp_leavetry)
3544 {
3545     dSP;
3546     register SV **mark;
3547     SV **newsp;
3548     PMOP *newpm;
3549     OP* retop;
3550     I32 gimme;
3551     register PERL_CONTEXT *cx;
3552     I32 optype;
3553
3554     POPBLOCK(cx,newpm);
3555     POPEVAL(cx);
3556     retop = cx->blk_eval.retop;
3557
3558     TAINT_NOT;
3559     if (gimme == G_VOID)
3560         SP = newsp;
3561     else if (gimme == G_SCALAR) {
3562         MARK = newsp + 1;
3563         if (MARK <= SP) {
3564             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3565                 *MARK = TOPs;
3566             else
3567                 *MARK = sv_mortalcopy(TOPs);
3568         }
3569         else {
3570             MEXTEND(mark,0);
3571             *MARK = &PL_sv_undef;
3572         }
3573         SP = MARK;
3574     }
3575     else {
3576         /* in case LEAVE wipes old return values */
3577         for (mark = newsp + 1; mark <= SP; mark++) {
3578             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3579                 *mark = sv_mortalcopy(*mark);
3580                 TAINT_NOT;      /* Each item is independent */
3581             }
3582         }
3583     }
3584     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3585
3586     LEAVE;
3587     sv_setpv(ERRSV,"");
3588     RETURNOP(retop);
3589 }
3590
3591 STATIC OP *
3592 S_doparseform(pTHX_ SV *sv)
3593 {
3594     STRLEN len;
3595     register char *s = SvPV_force(sv, len);
3596     register char *send = s + len;
3597     register char *base = Nullch;
3598     register I32 skipspaces = 0;
3599     bool noblank   = FALSE;
3600     bool repeat    = FALSE;
3601     bool postspace = FALSE;
3602     U32 *fops;
3603     register U32 *fpc;
3604     U32 *linepc = 0;
3605     register I32 arg;
3606     bool ischop;
3607     bool unchopnum = FALSE;
3608     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3609
3610     if (len == 0)
3611         Perl_croak(aTHX_ "Null picture in formline");
3612
3613     /* estimate the buffer size needed */
3614     for (base = s; s <= send; s++) {
3615         if (*s == '\n' || *s == '@' || *s == '^')
3616             maxops += 10;
3617     }
3618     s = base;
3619     base = Nullch;
3620
3621     New(804, fops, maxops, U32);
3622     fpc = fops;
3623
3624     if (s < send) {
3625         linepc = fpc;
3626         *fpc++ = FF_LINEMARK;
3627         noblank = repeat = FALSE;
3628         base = s;
3629     }
3630
3631     while (s <= send) {
3632         switch (*s++) {
3633         default:
3634             skipspaces = 0;
3635             continue;
3636
3637         case '~':
3638             if (*s == '~') {
3639                 repeat = TRUE;
3640                 *s = ' ';
3641             }
3642             noblank = TRUE;
3643             s[-1] = ' ';
3644             /* FALL THROUGH */
3645         case ' ': case '\t':
3646             skipspaces++;
3647             continue;
3648         case 0:
3649             if (s < send) {
3650                 skipspaces = 0;
3651                 continue;
3652             } /* else FALL THROUGH */
3653         case '\n':
3654             arg = s - base;
3655             skipspaces++;
3656             arg -= skipspaces;
3657             if (arg) {
3658                 if (postspace)
3659                     *fpc++ = FF_SPACE;
3660                 *fpc++ = FF_LITERAL;
3661                 *fpc++ = (U16)arg;
3662             }
3663             postspace = FALSE;
3664             if (s <= send)
3665                 skipspaces--;
3666             if (skipspaces) {
3667                 *fpc++ = FF_SKIP;
3668                 *fpc++ = (U16)skipspaces;
3669             }
3670             skipspaces = 0;
3671             if (s <= send)
3672                 *fpc++ = FF_NEWLINE;
3673             if (noblank) {
3674                 *fpc++ = FF_BLANK;
3675                 if (repeat)
3676                     arg = fpc - linepc + 1;
3677                 else
3678                     arg = 0;
3679                 *fpc++ = (U16)arg;
3680             }
3681             if (s < send) {
3682                 linepc = fpc;
3683                 *fpc++ = FF_LINEMARK;
3684                 noblank = repeat = FALSE;
3685                 base = s;
3686             }
3687             else
3688                 s++;
3689             continue;
3690
3691         case '@':
3692         case '^':
3693             ischop = s[-1] == '^';
3694
3695             if (postspace) {
3696                 *fpc++ = FF_SPACE;
3697                 postspace = FALSE;
3698             }
3699             arg = (s - base) - 1;
3700             if (arg) {
3701                 *fpc++ = FF_LITERAL;
3702                 *fpc++ = (U16)arg;
3703             }
3704
3705             base = s - 1;
3706             *fpc++ = FF_FETCH;
3707             if (*s == '*') {
3708                 s++;
3709                 *fpc++ = 2;  /* skip the @* or ^* */
3710                 if (ischop) {
3711                     *fpc++ = FF_LINESNGL;
3712                     *fpc++ = FF_CHOP;
3713                 } else
3714                     *fpc++ = FF_LINEGLOB;
3715             }
3716             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3717                 arg = ischop ? 512 : 0;
3718                 base = s - 1;
3719                 while (*s == '#')
3720                     s++;
3721                 if (*s == '.') {
3722                     char *f;
3723                     s++;
3724                     f = s;
3725                     while (*s == '#')
3726                         s++;
3727                     arg |= 256 + (s - f);
3728                 }
3729                 *fpc++ = s - base;              /* fieldsize for FETCH */
3730                 *fpc++ = FF_DECIMAL;
3731                 *fpc++ = (U16)arg;
3732                 unchopnum |= ! ischop;
3733             }
3734             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3735                 arg = ischop ? 512 : 0;
3736                 base = s - 1;
3737                 s++;                                /* skip the '0' first */
3738                 while (*s == '#')
3739                     s++;
3740                 if (*s == '.') {
3741                     char *f;
3742                     s++;
3743                     f = s;
3744                     while (*s == '#')
3745                         s++;
3746                     arg |= 256 + (s - f);
3747                 }
3748                 *fpc++ = s - base;                /* fieldsize for FETCH */
3749                 *fpc++ = FF_0DECIMAL;
3750                 *fpc++ = (U16)arg;
3751                 unchopnum |= ! ischop;
3752             }
3753             else {
3754                 I32 prespace = 0;
3755                 bool ismore = FALSE;
3756
3757                 if (*s == '>') {
3758                     while (*++s == '>') ;
3759                     prespace = FF_SPACE;
3760                 }
3761                 else if (*s == '|') {
3762                     while (*++s == '|') ;
3763                     prespace = FF_HALFSPACE;
3764                     postspace = TRUE;
3765                 }
3766                 else {
3767                     if (*s == '<')
3768                         while (*++s == '<') ;
3769                     postspace = TRUE;
3770                 }
3771                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3772                     s += 3;
3773                     ismore = TRUE;
3774                 }
3775                 *fpc++ = s - base;              /* fieldsize for FETCH */
3776
3777                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3778
3779                 if (prespace)
3780                     *fpc++ = (U16)prespace;
3781                 *fpc++ = FF_ITEM;
3782                 if (ismore)
3783                     *fpc++ = FF_MORE;
3784                 if (ischop)
3785                     *fpc++ = FF_CHOP;
3786             }
3787             base = s;
3788             skipspaces = 0;
3789             continue;
3790         }
3791     }
3792     *fpc++ = FF_END;
3793
3794     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3795     arg = fpc - fops;
3796     { /* need to jump to the next word */
3797         int z;
3798         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3799         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3800         s = SvPVX(sv) + SvCUR(sv) + z;
3801     }
3802     Copy(fops, s, arg, U32);
3803     Safefree(fops);
3804     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3805     SvCOMPILED_on(sv);
3806
3807     if (unchopnum && repeat)
3808         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3809     return 0;
3810 }
3811
3812
3813 STATIC bool
3814 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3815 {
3816     /* Can value be printed in fldsize chars, using %*.*f ? */
3817     NV pwr = 1;
3818     NV eps = 0.5;
3819     bool res = FALSE;
3820     int intsize = fldsize - (value < 0 ? 1 : 0);
3821
3822     if (frcsize & 256)
3823         intsize--;
3824     frcsize &= 255;
3825     intsize -= frcsize;
3826
3827     while (intsize--) pwr *= 10.0;
3828     while (frcsize--) eps /= 10.0;
3829
3830     if( value >= 0 ){
3831         if (value + eps >= pwr)
3832             res = TRUE;
3833     } else {
3834         if (value - eps <= -pwr)
3835             res = TRUE;
3836     }
3837     return res;
3838 }
3839
3840 static I32
3841 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3842 {
3843     SV *datasv = FILTER_DATA(idx);
3844     int filter_has_file = IoLINES(datasv);
3845     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3846     SV *filter_state = (SV *)IoTOP_GV(datasv);
3847     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3848     int len = 0;
3849
3850     /* I was having segfault trouble under Linux 2.2.5 after a
3851        parse error occured.  (Had to hack around it with a test
3852        for PL_error_count == 0.)  Solaris doesn't segfault --
3853        not sure where the trouble is yet.  XXX */
3854
3855     if (filter_has_file) {
3856         len = FILTER_READ(idx+1, buf_sv, maxlen);
3857     }
3858
3859     if (filter_sub && len >= 0) {
3860         dSP;
3861         int count;
3862
3863         ENTER;
3864         SAVE_DEFSV;
3865         SAVETMPS;
3866         EXTEND(SP, 2);
3867
3868         DEFSV = buf_sv;
3869         PUSHMARK(SP);
3870         PUSHs(sv_2mortal(newSViv(maxlen)));
3871         if (filter_state) {
3872             PUSHs(filter_state);
3873         }
3874         PUTBACK;
3875         count = call_sv(filter_sub, G_SCALAR);
3876         SPAGAIN;
3877
3878         if (count > 0) {
3879             SV *out = POPs;
3880             if (SvOK(out)) {
3881                 len = SvIV(out);
3882             }
3883         }
3884
3885         PUTBACK;
3886         FREETMPS;
3887         LEAVE;
3888     }
3889
3890     if (len <= 0) {
3891         IoLINES(datasv) = 0;
3892         if (filter_child_proc) {
3893             SvREFCNT_dec(filter_child_proc);
3894             IoFMT_GV(datasv) = Nullgv;
3895         }
3896         if (filter_state) {
3897             SvREFCNT_dec(filter_state);
3898             IoTOP_GV(datasv) = Nullgv;
3899         }
3900         if (filter_sub) {
3901             SvREFCNT_dec(filter_sub);
3902             IoBOTTOM_GV(datasv) = Nullgv;
3903         }
3904         filter_del(run_user_filter);
3905     }
3906
3907     return len;
3908 }
3909
3910 /* perhaps someone can come up with a better name for
3911    this?  it is not really "absolute", per se ... */
3912 static bool
3913 S_path_is_absolute(pTHX_ char *name)
3914 {
3915     if (PERL_FILE_IS_ABSOLUTE(name)
3916 #ifdef MACOS_TRADITIONAL
3917         || (*name == ':'))
3918 #else
3919         || (*name == '.' && (name[1] == '/' ||
3920                              (name[1] == '.' && name[2] == '/'))))
3921 #endif
3922     {
3923         return TRUE;
3924     }
3925     else
3926         return FALSE;
3927 }
3928
3929 /*
3930  * Local variables:
3931  * c-indentation-style: bsd
3932  * c-basic-offset: 4
3933  * indent-tabs-mode: t
3934  * End:
3935  *
3936  * vim: shiftwidth=4:
3937 */