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             SvPV_set(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             SvPV_set(dstr, (char*)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_ const char *label)
1199 {
1200     register I32 i;
1201
1202     for (i = cxstack_ix; i >= 0; i--) {
1203         register const PERL_CONTEXT *cx = &cxstack[i];
1204         switch (CxTYPE(cx)) {
1205         case CXt_SUBST:
1206         case CXt_SUB:
1207         case CXt_FORMAT:
1208         case CXt_EVAL:
1209         case CXt_NULL:
1210             if (ckWARN(WARN_EXITING))
1211                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1212                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1213             if (CxTYPE(cx) == CXt_NULL)
1214                 return -1;
1215             break;
1216         case CXt_LOOP:
1217             if (!cx->blk_loop.label ||
1218               strNE(label, cx->blk_loop.label) ) {
1219                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1220                         (long)i, cx->blk_loop.label));
1221                 continue;
1222             }
1223             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1224             return i;
1225         }
1226     }
1227     return i;
1228 }
1229
1230 I32
1231 Perl_dowantarray(pTHX)
1232 {
1233     I32 gimme = block_gimme();
1234     return (gimme == G_VOID) ? G_SCALAR : gimme;
1235 }
1236
1237 I32
1238 Perl_block_gimme(pTHX)
1239 {
1240     const I32 cxix = dopoptosub(cxstack_ix);
1241     if (cxix < 0)
1242         return G_VOID;
1243
1244     switch (cxstack[cxix].blk_gimme) {
1245     case G_VOID:
1246         return G_VOID;
1247     case G_SCALAR:
1248         return G_SCALAR;
1249     case G_ARRAY:
1250         return G_ARRAY;
1251     default:
1252         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1253         /* NOTREACHED */
1254         return 0;
1255     }
1256 }
1257
1258 I32
1259 Perl_is_lvalue_sub(pTHX)
1260 {
1261     const I32 cxix = dopoptosub(cxstack_ix);
1262     assert(cxix >= 0);  /* We should only be called from inside subs */
1263
1264     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1265         return cxstack[cxix].blk_sub.lval;
1266     else
1267         return 0;
1268 }
1269
1270 STATIC I32
1271 S_dopoptosub(pTHX_ I32 startingblock)
1272 {
1273     return dopoptosub_at(cxstack, startingblock);
1274 }
1275
1276 STATIC I32
1277 S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
1278 {
1279     I32 i;
1280     for (i = startingblock; i >= 0; i--) {
1281         register const PERL_CONTEXT *cx = &cxstk[i];
1282         switch (CxTYPE(cx)) {
1283         default:
1284             continue;
1285         case CXt_EVAL:
1286         case CXt_SUB:
1287         case CXt_FORMAT:
1288             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1289             return i;
1290         }
1291     }
1292     return i;
1293 }
1294
1295 STATIC I32
1296 S_dopoptoeval(pTHX_ I32 startingblock)
1297 {
1298     I32 i;
1299     for (i = startingblock; i >= 0; i--) {
1300         register const PERL_CONTEXT *cx = &cxstack[i];
1301         switch (CxTYPE(cx)) {
1302         default:
1303             continue;
1304         case CXt_EVAL:
1305             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1306             return i;
1307         }
1308     }
1309     return i;
1310 }
1311
1312 STATIC I32
1313 S_dopoptoloop(pTHX_ I32 startingblock)
1314 {
1315     I32 i;
1316     for (i = startingblock; i >= 0; i--) {
1317         register const PERL_CONTEXT *cx = &cxstack[i];
1318         switch (CxTYPE(cx)) {
1319         case CXt_SUBST:
1320         case CXt_SUB:
1321         case CXt_FORMAT:
1322         case CXt_EVAL:
1323         case CXt_NULL:
1324             if (ckWARN(WARN_EXITING))
1325                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1326                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1327             if ((CxTYPE(cx)) == CXt_NULL)
1328                 return -1;
1329             break;
1330         case CXt_LOOP:
1331             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1332             return i;
1333         }
1334     }
1335     return i;
1336 }
1337
1338 void
1339 Perl_dounwind(pTHX_ I32 cxix)
1340 {
1341     I32 optype;
1342
1343     while (cxstack_ix > cxix) {
1344         SV *sv;
1345         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1346         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1347                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1348         /* Note: we don't need to restore the base context info till the end. */
1349         switch (CxTYPE(cx)) {
1350         case CXt_SUBST:
1351             POPSUBST(cx);
1352             continue;  /* not break */
1353         case CXt_SUB:
1354             POPSUB(cx,sv);
1355             LEAVESUB(sv);
1356             break;
1357         case CXt_EVAL:
1358             POPEVAL(cx);
1359             break;
1360         case CXt_LOOP:
1361             POPLOOP(cx);
1362             break;
1363         case CXt_NULL:
1364             break;
1365         case CXt_FORMAT:
1366             POPFORMAT(cx);
1367             break;
1368         }
1369         cxstack_ix--;
1370     }
1371 }
1372
1373 void
1374 Perl_qerror(pTHX_ SV *err)
1375 {
1376     if (PL_in_eval)
1377         sv_catsv(ERRSV, err);
1378     else if (PL_errors)
1379         sv_catsv(PL_errors, err);
1380     else
1381         Perl_warn(aTHX_ "%"SVf, err);
1382     ++PL_error_count;
1383 }
1384
1385 OP *
1386 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1387 {
1388     STRLEN n_a;
1389
1390     if (PL_in_eval) {
1391         I32 cxix;
1392         I32 gimme;
1393         SV **newsp;
1394
1395         if (message) {
1396             if (PL_in_eval & EVAL_KEEPERR) {
1397                 static const char prefix[] = "\t(in cleanup) ";
1398                 SV *err = ERRSV;
1399                 const char *e = Nullch;
1400                 if (!SvPOK(err))
1401                     sv_setpv(err,"");
1402                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1403                     e = SvPV(err, n_a);
1404                     e += n_a - msglen;
1405                     if (*e != *message || strNE(e,message))
1406                         e = Nullch;
1407                 }
1408                 if (!e) {
1409                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1410                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1411                     sv_catpvn(err, message, msglen);
1412                     if (ckWARN(WARN_MISC)) {
1413                         STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1414                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX(err)+start);
1415                     }
1416                 }
1417             }
1418             else {
1419                 sv_setpvn(ERRSV, message, msglen);
1420             }
1421         }
1422
1423         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1424                && PL_curstackinfo->si_prev)
1425         {
1426             dounwind(-1);
1427             POPSTACK;
1428         }
1429
1430         if (cxix >= 0) {
1431             I32 optype;
1432             register PERL_CONTEXT *cx;
1433
1434             if (cxix < cxstack_ix)
1435                 dounwind(cxix);
1436
1437             POPBLOCK(cx,PL_curpm);
1438             if (CxTYPE(cx) != CXt_EVAL) {
1439                 if (!message)
1440                     message = SvPVx(ERRSV, msglen);
1441                 PerlIO_write(Perl_error_log, "panic: die ", 11);
1442                 PerlIO_write(Perl_error_log, message, msglen);
1443                 my_exit(1);
1444             }
1445             POPEVAL(cx);
1446
1447             if (gimme == G_SCALAR)
1448                 *++newsp = &PL_sv_undef;
1449             PL_stack_sp = newsp;
1450
1451             LEAVE;
1452
1453             /* LEAVE could clobber PL_curcop (see save_re_context())
1454              * XXX it might be better to find a way to avoid messing with
1455              * PL_curcop in save_re_context() instead, but this is a more
1456              * minimal fix --GSAR */
1457             PL_curcop = cx->blk_oldcop;
1458
1459             if (optype == OP_REQUIRE) {
1460                 const char* msg = SvPVx(ERRSV, n_a);
1461                 SV *nsv = cx->blk_eval.old_namesv;
1462                 (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
1463                                &PL_sv_undef, 0);
1464                 DIE(aTHX_ "%sCompilation failed in require",
1465                     *msg ? msg : "Unknown error\n");
1466             }
1467             assert(CxTYPE(cx) == CXt_EVAL);
1468             return cx->blk_eval.retop;
1469         }
1470     }
1471     if (!message)
1472         message = SvPVx(ERRSV, msglen);
1473
1474     write_to_stderr(message, msglen);
1475     my_failure_exit();
1476     /* NOTREACHED */
1477     return 0;
1478 }
1479
1480 PP(pp_xor)
1481 {
1482     dSP; dPOPTOPssrl;
1483     if (SvTRUE(left) != SvTRUE(right))
1484         RETSETYES;
1485     else
1486         RETSETNO;
1487 }
1488
1489 PP(pp_andassign)
1490 {
1491     dSP;
1492     if (!SvTRUE(TOPs))
1493         RETURN;
1494     else
1495         RETURNOP(cLOGOP->op_other);
1496 }
1497
1498 PP(pp_orassign)
1499 {
1500     dSP;
1501     if (SvTRUE(TOPs))
1502         RETURN;
1503     else
1504         RETURNOP(cLOGOP->op_other);
1505 }
1506
1507 PP(pp_dorassign)
1508 {
1509     dSP;
1510     register SV* sv;
1511
1512     sv = TOPs;
1513     if (!sv || !SvANY(sv)) {
1514         RETURNOP(cLOGOP->op_other);
1515     }
1516
1517     switch (SvTYPE(sv)) {
1518     case SVt_PVAV:
1519         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1520             RETURN;
1521         break;
1522     case SVt_PVHV:
1523         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
1524             RETURN;
1525         break;
1526     case SVt_PVCV:
1527         if (CvROOT(sv) || CvXSUB(sv))
1528             RETURN;
1529         break;
1530     default:
1531         if (SvGMAGICAL(sv))
1532             mg_get(sv);
1533         if (SvOK(sv))
1534             RETURN;
1535     }
1536
1537     RETURNOP(cLOGOP->op_other);
1538 }
1539
1540 PP(pp_caller)
1541 {
1542     dSP;
1543     register I32 cxix = dopoptosub(cxstack_ix);
1544     register PERL_CONTEXT *cx;
1545     register PERL_CONTEXT *ccstack = cxstack;
1546     PERL_SI *top_si = PL_curstackinfo;
1547     I32 dbcxix;
1548     I32 gimme;
1549     const char *stashname;
1550     SV *sv;
1551     I32 count = 0;
1552
1553     if (MAXARG)
1554         count = POPi;
1555
1556     for (;;) {
1557         /* we may be in a higher stacklevel, so dig down deeper */
1558         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1559             top_si = top_si->si_prev;
1560             ccstack = top_si->si_cxstack;
1561             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1562         }
1563         if (cxix < 0) {
1564             if (GIMME != G_ARRAY) {
1565                 EXTEND(SP, 1);
1566                 RETPUSHUNDEF;
1567             }
1568             RETURN;
1569         }
1570         /* caller() should not report the automatic calls to &DB::sub */
1571         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1572                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1573             count++;
1574         if (!count--)
1575             break;
1576         cxix = dopoptosub_at(ccstack, cxix - 1);
1577     }
1578
1579     cx = &ccstack[cxix];
1580     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1581         dbcxix = dopoptosub_at(ccstack, cxix - 1);
1582         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1583            field below is defined for any cx. */
1584         /* caller() should not report the automatic calls to &DB::sub */
1585         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1586             cx = &ccstack[dbcxix];
1587     }
1588
1589     stashname = CopSTASHPV(cx->blk_oldcop);
1590     if (GIMME != G_ARRAY) {
1591         EXTEND(SP, 1);
1592         if (!stashname)
1593             PUSHs(&PL_sv_undef);
1594         else {
1595             dTARGET;
1596             sv_setpv(TARG, stashname);
1597             PUSHs(TARG);
1598         }
1599         RETURN;
1600     }
1601
1602     EXTEND(SP, 10);
1603
1604     if (!stashname)
1605         PUSHs(&PL_sv_undef);
1606     else
1607         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1608     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1609     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1610     if (!MAXARG)
1611         RETURN;
1612     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1613         GV *cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1614         /* So is ccstack[dbcxix]. */
1615         if (isGV(cvgv)) {
1616             sv = NEWSV(49, 0);
1617             gv_efullname3(sv, cvgv, Nullch);
1618             PUSHs(sv_2mortal(sv));
1619             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1620         }
1621         else {
1622             PUSHs(sv_2mortal(newSVpvn("(unknown)",9)));
1623             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1624         }
1625     }
1626     else {
1627         PUSHs(sv_2mortal(newSVpvn("(eval)",6)));
1628         PUSHs(sv_2mortal(newSViv(0)));
1629     }
1630     gimme = (I32)cx->blk_gimme;
1631     if (gimme == G_VOID)
1632         PUSHs(&PL_sv_undef);
1633     else
1634         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1635     if (CxTYPE(cx) == CXt_EVAL) {
1636         /* eval STRING */
1637         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1638             PUSHs(cx->blk_eval.cur_text);
1639             PUSHs(&PL_sv_no);
1640         }
1641         /* require */
1642         else if (cx->blk_eval.old_namesv) {
1643             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1644             PUSHs(&PL_sv_yes);
1645         }
1646         /* eval BLOCK (try blocks have old_namesv == 0) */
1647         else {
1648             PUSHs(&PL_sv_undef);
1649             PUSHs(&PL_sv_undef);
1650         }
1651     }
1652     else {
1653         PUSHs(&PL_sv_undef);
1654         PUSHs(&PL_sv_undef);
1655     }
1656     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1657         && CopSTASH_eq(PL_curcop, PL_debstash))
1658     {
1659         AV *ary = cx->blk_sub.argarray;
1660         const int off = AvARRAY(ary) - AvALLOC(ary);
1661
1662         if (!PL_dbargs) {
1663             GV* tmpgv;
1664             PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
1665                                 SVt_PVAV)));
1666             GvMULTI_on(tmpgv);
1667             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1668         }
1669
1670         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1671             av_extend(PL_dbargs, AvFILLp(ary) + off);
1672         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1673         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1674     }
1675     /* XXX only hints propagated via op_private are currently
1676      * visible (others are not easily accessible, since they
1677      * use the global PL_hints) */
1678     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
1679                              HINT_PRIVATE_MASK)));
1680     {
1681         SV * mask ;
1682         SV * old_warnings = cx->blk_oldcop->cop_warnings ;
1683
1684         if  (old_warnings == pWARN_NONE ||
1685                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1686             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1687         else if (old_warnings == pWARN_ALL ||
1688                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1689             /* Get the bit mask for $warnings::Bits{all}, because
1690              * it could have been extended by warnings::register */
1691             SV **bits_all;
1692             HV *bits = get_hv("warnings::Bits", FALSE);
1693             if (bits && (bits_all=hv_fetch(bits, "all", 3, FALSE))) {
1694                 mask = newSVsv(*bits_all);
1695             }
1696             else {
1697                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1698             }
1699         }
1700         else
1701             mask = newSVsv(old_warnings);
1702         PUSHs(sv_2mortal(mask));
1703     }
1704     RETURN;
1705 }
1706
1707 PP(pp_reset)
1708 {
1709     dSP;
1710     const char *tmps;
1711     STRLEN n_a;
1712
1713     if (MAXARG < 1)
1714         tmps = "";
1715     else
1716         tmps = POPpx;
1717     sv_reset(tmps, CopSTASH(PL_curcop));
1718     PUSHs(&PL_sv_yes);
1719     RETURN;
1720 }
1721
1722 PP(pp_lineseq)
1723 {
1724     return NORMAL;
1725 }
1726
1727 /* like pp_nextstate, but used instead when the debugger is active */
1728
1729 PP(pp_dbstate)
1730 {
1731     PL_curcop = (COP*)PL_op;
1732     TAINT_NOT;          /* Each statement is presumed innocent */
1733     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1734     FREETMPS;
1735
1736     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1737             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1738     {
1739         dSP;
1740         register CV *cv;
1741         register PERL_CONTEXT *cx;
1742         I32 gimme = G_ARRAY;
1743         U8 hasargs;
1744         GV *gv;
1745
1746         gv = PL_DBgv;
1747         cv = GvCV(gv);
1748         if (!cv)
1749             DIE(aTHX_ "No DB::DB routine defined");
1750
1751         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1752             /* don't do recursive DB::DB call */
1753             return NORMAL;
1754
1755         ENTER;
1756         SAVETMPS;
1757
1758         SAVEI32(PL_debug);
1759         SAVESTACK_POS();
1760         PL_debug = 0;
1761         hasargs = 0;
1762         SPAGAIN;
1763
1764         PUSHBLOCK(cx, CXt_SUB, SP);
1765         PUSHSUB_DB(cx);
1766         cx->blk_sub.retop = PL_op->op_next;
1767         CvDEPTH(cv)++;
1768         PAD_SET_CUR(CvPADLIST(cv),1);
1769         RETURNOP(CvSTART(cv));
1770     }
1771     else
1772         return NORMAL;
1773 }
1774
1775 PP(pp_scope)
1776 {
1777     return NORMAL;
1778 }
1779
1780 PP(pp_enteriter)
1781 {
1782     dSP; dMARK;
1783     register PERL_CONTEXT *cx;
1784     I32 gimme = GIMME_V;
1785     SV **svp;
1786     U32 cxtype = CXt_LOOP;
1787 #ifdef USE_ITHREADS
1788     void *iterdata;
1789 #endif
1790
1791     ENTER;
1792     SAVETMPS;
1793
1794     if (PL_op->op_targ) {
1795         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1796             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1797             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1798                     SVs_PADSTALE, SVs_PADSTALE);
1799         }
1800 #ifndef USE_ITHREADS
1801         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1802         SAVESPTR(*svp);
1803 #else
1804         SAVEPADSV(PL_op->op_targ);
1805         iterdata = INT2PTR(void*, PL_op->op_targ);
1806         cxtype |= CXp_PADVAR;
1807 #endif
1808     }
1809     else {
1810         GV *gv = (GV*)POPs;
1811         svp = &GvSV(gv);                        /* symbol table variable */
1812         SAVEGENERICSV(*svp);
1813         *svp = NEWSV(0,0);
1814 #ifdef USE_ITHREADS
1815         iterdata = (void*)gv;
1816 #endif
1817     }
1818
1819     ENTER;
1820
1821     PUSHBLOCK(cx, cxtype, SP);
1822 #ifdef USE_ITHREADS
1823     PUSHLOOP(cx, iterdata, MARK);
1824 #else
1825     PUSHLOOP(cx, svp, MARK);
1826 #endif
1827     if (PL_op->op_flags & OPf_STACKED) {
1828         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1829         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1830             dPOPss;
1831             SV *right = (SV*)cx->blk_loop.iterary;
1832             if (RANGE_IS_NUMERIC(sv,right)) {
1833                 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1834                     (SvOK(right) && SvNV(right) >= IV_MAX))
1835                     DIE(aTHX_ "Range iterator outside integer range");
1836                 cx->blk_loop.iterix = SvIV(sv);
1837                 cx->blk_loop.itermax = SvIV(right);
1838             }
1839             else {
1840                 STRLEN n_a;
1841                 cx->blk_loop.iterlval = newSVsv(sv);
1842                 (void) SvPV_force(cx->blk_loop.iterlval,n_a);
1843                 (void) SvPV(right,n_a);
1844             }
1845         }
1846         else if (PL_op->op_private & OPpITER_REVERSED) {
1847             cx->blk_loop.itermax = -1;
1848             cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary);
1849
1850         }
1851     }
1852     else {
1853         cx->blk_loop.iterary = PL_curstack;
1854         AvFILLp(PL_curstack) = SP - PL_stack_base;
1855         if (PL_op->op_private & OPpITER_REVERSED) {
1856             cx->blk_loop.itermax = MARK - PL_stack_base;
1857             cx->blk_loop.iterix = cx->blk_oldsp;
1858         }
1859         else {
1860             cx->blk_loop.iterix = MARK - PL_stack_base;
1861         }
1862     }
1863
1864     RETURN;
1865 }
1866
1867 PP(pp_enterloop)
1868 {
1869     dSP;
1870     register PERL_CONTEXT *cx;
1871     I32 gimme = GIMME_V;
1872
1873     ENTER;
1874     SAVETMPS;
1875     ENTER;
1876
1877     PUSHBLOCK(cx, CXt_LOOP, SP);
1878     PUSHLOOP(cx, 0, SP);
1879
1880     RETURN;
1881 }
1882
1883 PP(pp_leaveloop)
1884 {
1885     dSP;
1886     register PERL_CONTEXT *cx;
1887     I32 gimme;
1888     SV **newsp;
1889     PMOP *newpm;
1890     SV **mark;
1891
1892     POPBLOCK(cx,newpm);
1893     mark = newsp;
1894     newsp = PL_stack_base + cx->blk_loop.resetsp;
1895
1896     TAINT_NOT;
1897     if (gimme == G_VOID)
1898         ; /* do nothing */
1899     else if (gimme == G_SCALAR) {
1900         if (mark < SP)
1901             *++newsp = sv_mortalcopy(*SP);
1902         else
1903             *++newsp = &PL_sv_undef;
1904     }
1905     else {
1906         while (mark < SP) {
1907             *++newsp = sv_mortalcopy(*++mark);
1908             TAINT_NOT;          /* Each item is independent */
1909         }
1910     }
1911     SP = newsp;
1912     PUTBACK;
1913
1914     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1915     PL_curpm = newpm;   /* ... and pop $1 et al */
1916
1917     LEAVE;
1918     LEAVE;
1919
1920     return NORMAL;
1921 }
1922
1923 PP(pp_return)
1924 {
1925     dSP; dMARK;
1926     I32 cxix;
1927     register PERL_CONTEXT *cx;
1928     bool popsub2 = FALSE;
1929     bool clear_errsv = FALSE;
1930     I32 gimme;
1931     SV **newsp;
1932     PMOP *newpm;
1933     I32 optype = 0;
1934     SV *sv;
1935     OP *retop;
1936
1937     if (PL_curstackinfo->si_type == PERLSI_SORT) {
1938         if (cxstack_ix == PL_sortcxix
1939             || dopoptosub(cxstack_ix) <= PL_sortcxix)
1940         {
1941             if (cxstack_ix > PL_sortcxix)
1942                 dounwind(PL_sortcxix);
1943             AvARRAY(PL_curstack)[1] = *SP;
1944             PL_stack_sp = PL_stack_base + 1;
1945             return 0;
1946         }
1947     }
1948
1949     cxix = dopoptosub(cxstack_ix);
1950     if (cxix < 0)
1951         DIE(aTHX_ "Can't return outside a subroutine");
1952     if (cxix < cxstack_ix)
1953         dounwind(cxix);
1954
1955     POPBLOCK(cx,newpm);
1956     switch (CxTYPE(cx)) {
1957     case CXt_SUB:
1958         popsub2 = TRUE;
1959         retop = cx->blk_sub.retop;
1960         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
1961         break;
1962     case CXt_EVAL:
1963         if (!(PL_in_eval & EVAL_KEEPERR))
1964             clear_errsv = TRUE;
1965         POPEVAL(cx);
1966         retop = cx->blk_eval.retop;
1967         if (CxTRYBLOCK(cx))
1968             break;
1969         lex_end();
1970         if (optype == OP_REQUIRE &&
1971             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
1972         {
1973             /* Unassume the success we assumed earlier. */
1974             SV *nsv = cx->blk_eval.old_namesv;
1975             (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
1976             DIE(aTHX_ "%"SVf" did not return a true value", nsv);
1977         }
1978         break;
1979     case CXt_FORMAT:
1980         POPFORMAT(cx);
1981         retop = cx->blk_sub.retop;
1982         break;
1983     default:
1984         DIE(aTHX_ "panic: return");
1985     }
1986
1987     TAINT_NOT;
1988     if (gimme == G_SCALAR) {
1989         if (MARK < SP) {
1990             if (popsub2) {
1991                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
1992                     if (SvTEMP(TOPs)) {
1993                         *++newsp = SvREFCNT_inc(*SP);
1994                         FREETMPS;
1995                         sv_2mortal(*newsp);
1996                     }
1997                     else {
1998                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
1999                         FREETMPS;
2000                         *++newsp = sv_mortalcopy(sv);
2001                         SvREFCNT_dec(sv);
2002                     }
2003                 }
2004                 else
2005                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2006             }
2007             else
2008                 *++newsp = sv_mortalcopy(*SP);
2009         }
2010         else
2011             *++newsp = &PL_sv_undef;
2012     }
2013     else if (gimme == G_ARRAY) {
2014         while (++MARK <= SP) {
2015             *++newsp = (popsub2 && SvTEMP(*MARK))
2016                         ? *MARK : sv_mortalcopy(*MARK);
2017             TAINT_NOT;          /* Each item is independent */
2018         }
2019     }
2020     PL_stack_sp = newsp;
2021
2022     LEAVE;
2023     /* Stack values are safe: */
2024     if (popsub2) {
2025         cxstack_ix--;
2026         POPSUB(cx,sv);  /* release CV and @_ ... */
2027     }
2028     else
2029         sv = Nullsv;
2030     PL_curpm = newpm;   /* ... and pop $1 et al */
2031
2032     LEAVESUB(sv);
2033     if (clear_errsv)
2034         sv_setpv(ERRSV,"");
2035     return retop;
2036 }
2037
2038 PP(pp_last)
2039 {
2040     dSP;
2041     I32 cxix;
2042     register PERL_CONTEXT *cx;
2043     I32 pop2 = 0;
2044     I32 gimme;
2045     I32 optype;
2046     OP *nextop;
2047     SV **newsp;
2048     PMOP *newpm;
2049     SV **mark;
2050     SV *sv = Nullsv;
2051
2052     if (PL_op->op_flags & OPf_SPECIAL) {
2053         cxix = dopoptoloop(cxstack_ix);
2054         if (cxix < 0)
2055             DIE(aTHX_ "Can't \"last\" outside a loop block");
2056     }
2057     else {
2058         cxix = dopoptolabel(cPVOP->op_pv);
2059         if (cxix < 0)
2060             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2061     }
2062     if (cxix < cxstack_ix)
2063         dounwind(cxix);
2064
2065     POPBLOCK(cx,newpm);
2066     cxstack_ix++; /* temporarily protect top context */
2067     mark = newsp;
2068     switch (CxTYPE(cx)) {
2069     case CXt_LOOP:
2070         pop2 = CXt_LOOP;
2071         newsp = PL_stack_base + cx->blk_loop.resetsp;
2072         nextop = cx->blk_loop.last_op->op_next;
2073         break;
2074     case CXt_SUB:
2075         pop2 = CXt_SUB;
2076         nextop = cx->blk_sub.retop;
2077         break;
2078     case CXt_EVAL:
2079         POPEVAL(cx);
2080         nextop = cx->blk_eval.retop;
2081         break;
2082     case CXt_FORMAT:
2083         POPFORMAT(cx);
2084         nextop = cx->blk_sub.retop;
2085         break;
2086     default:
2087         DIE(aTHX_ "panic: last");
2088     }
2089
2090     TAINT_NOT;
2091     if (gimme == G_SCALAR) {
2092         if (MARK < SP)
2093             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2094                         ? *SP : sv_mortalcopy(*SP);
2095         else
2096             *++newsp = &PL_sv_undef;
2097     }
2098     else if (gimme == G_ARRAY) {
2099         while (++MARK <= SP) {
2100             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2101                         ? *MARK : sv_mortalcopy(*MARK);
2102             TAINT_NOT;          /* Each item is independent */
2103         }
2104     }
2105     SP = newsp;
2106     PUTBACK;
2107
2108     LEAVE;
2109     cxstack_ix--;
2110     /* Stack values are safe: */
2111     switch (pop2) {
2112     case CXt_LOOP:
2113         POPLOOP(cx);    /* release loop vars ... */
2114         LEAVE;
2115         break;
2116     case CXt_SUB:
2117         POPSUB(cx,sv);  /* release CV and @_ ... */
2118         break;
2119     }
2120     PL_curpm = newpm;   /* ... and pop $1 et al */
2121
2122     LEAVESUB(sv);
2123     return nextop;
2124 }
2125
2126 PP(pp_next)
2127 {
2128     I32 cxix;
2129     register PERL_CONTEXT *cx;
2130     I32 inner;
2131
2132     if (PL_op->op_flags & OPf_SPECIAL) {
2133         cxix = dopoptoloop(cxstack_ix);
2134         if (cxix < 0)
2135             DIE(aTHX_ "Can't \"next\" outside a loop block");
2136     }
2137     else {
2138         cxix = dopoptolabel(cPVOP->op_pv);
2139         if (cxix < 0)
2140             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2141     }
2142     if (cxix < cxstack_ix)
2143         dounwind(cxix);
2144
2145     /* clear off anything above the scope we're re-entering, but
2146      * save the rest until after a possible continue block */
2147     inner = PL_scopestack_ix;
2148     TOPBLOCK(cx);
2149     if (PL_scopestack_ix < inner)
2150         leave_scope(PL_scopestack[PL_scopestack_ix]);
2151     return cx->blk_loop.next_op;
2152 }
2153
2154 PP(pp_redo)
2155 {
2156     I32 cxix;
2157     register PERL_CONTEXT *cx;
2158     I32 oldsave;
2159
2160     if (PL_op->op_flags & OPf_SPECIAL) {
2161         cxix = dopoptoloop(cxstack_ix);
2162         if (cxix < 0)
2163             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2164     }
2165     else {
2166         cxix = dopoptolabel(cPVOP->op_pv);
2167         if (cxix < 0)
2168             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2169     }
2170     if (cxix < cxstack_ix)
2171         dounwind(cxix);
2172
2173     TOPBLOCK(cx);
2174     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2175     LEAVE_SCOPE(oldsave);
2176     FREETMPS;
2177     return cx->blk_loop.redo_op;
2178 }
2179
2180 STATIC OP *
2181 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2182 {
2183     OP *kid = Nullop;
2184     OP **ops = opstack;
2185     static const char too_deep[] = "Target of goto is too deeply nested";
2186
2187     if (ops >= oplimit)
2188         Perl_croak(aTHX_ too_deep);
2189     if (o->op_type == OP_LEAVE ||
2190         o->op_type == OP_SCOPE ||
2191         o->op_type == OP_LEAVELOOP ||
2192         o->op_type == OP_LEAVESUB ||
2193         o->op_type == OP_LEAVETRY)
2194     {
2195         *ops++ = cUNOPo->op_first;
2196         if (ops >= oplimit)
2197             Perl_croak(aTHX_ too_deep);
2198     }
2199     *ops = 0;
2200     if (o->op_flags & OPf_KIDS) {
2201         /* First try all the kids at this level, since that's likeliest. */
2202         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2203             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2204                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2205                 return kid;
2206         }
2207         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2208             if (kid == PL_lastgotoprobe)
2209                 continue;
2210             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2211                 if (ops == opstack)
2212                     *ops++ = kid;
2213                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2214                          ops[-1]->op_type == OP_DBSTATE)
2215                     ops[-1] = kid;
2216                 else
2217                     *ops++ = kid;
2218             }
2219             if ((o = dofindlabel(kid, label, ops, oplimit)))
2220                 return o;
2221         }
2222     }
2223     *ops = 0;
2224     return 0;
2225 }
2226
2227 PP(pp_dump)
2228 {
2229     return pp_goto();
2230     /*NOTREACHED*/
2231 }
2232
2233 PP(pp_goto)
2234 {
2235     dSP;
2236     OP *retop = 0;
2237     I32 ix;
2238     register PERL_CONTEXT *cx;
2239 #define GOTO_DEPTH 64
2240     OP *enterops[GOTO_DEPTH];
2241     const char *label = 0;
2242     const bool do_dump = (PL_op->op_type == OP_DUMP);
2243     static const char must_have_label[] = "goto must have label";
2244
2245     if (PL_op->op_flags & OPf_STACKED) {
2246         SV *sv = POPs;
2247         STRLEN n_a;
2248
2249         /* This egregious kludge implements goto &subroutine */
2250         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2251             I32 cxix;
2252             register PERL_CONTEXT *cx;
2253             CV* cv = (CV*)SvRV(sv);
2254             SV** mark;
2255             I32 items = 0;
2256             I32 oldsave;
2257             bool reified = 0;
2258
2259         retry:
2260             if (!CvROOT(cv) && !CvXSUB(cv)) {
2261                 const GV * const gv = CvGV(cv);
2262                 if (gv) {
2263                     GV *autogv;
2264                     SV *tmpstr;
2265                     /* autoloaded stub? */
2266                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2267                         goto retry;
2268                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2269                                           GvNAMELEN(gv), FALSE);
2270                     if (autogv && (cv = GvCV(autogv)))
2271                         goto retry;
2272                     tmpstr = sv_newmortal();
2273                     gv_efullname3(tmpstr, gv, Nullch);
2274                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr);
2275                 }
2276                 DIE(aTHX_ "Goto undefined subroutine");
2277             }
2278
2279             /* First do some returnish stuff. */
2280             (void)SvREFCNT_inc(cv); /* avoid premature free during unwind */
2281             FREETMPS;
2282             cxix = dopoptosub(cxstack_ix);
2283             if (cxix < 0)
2284                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2285             if (cxix < cxstack_ix)
2286                 dounwind(cxix);
2287             TOPBLOCK(cx);
2288             if (CxREALEVAL(cx))
2289                 DIE(aTHX_ "Can't goto subroutine from an eval-string");
2290             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2291                 /* put @_ back onto stack */
2292                 AV* av = cx->blk_sub.argarray;
2293
2294                 items = AvFILLp(av) + 1;
2295                 EXTEND(SP, items+1); /* @_ could have been extended. */
2296                 Copy(AvARRAY(av), SP + 1, items, SV*);
2297                 SvREFCNT_dec(GvAV(PL_defgv));
2298                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2299                 CLEAR_ARGARRAY(av);
2300                 /* abandon @_ if it got reified */
2301                 if (AvREAL(av)) {
2302                     reified = 1;
2303                     SvREFCNT_dec(av);
2304                     av = newAV();
2305                     av_extend(av, items-1);
2306                     AvFLAGS(av) = AVf_REIFY;
2307                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2308                 }
2309             }
2310             else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
2311                 AV* av;
2312                 av = GvAV(PL_defgv);
2313                 items = AvFILLp(av) + 1;
2314                 EXTEND(SP, items+1); /* @_ could have been extended. */
2315                 Copy(AvARRAY(av), SP + 1, items, SV*);
2316             }
2317             mark = SP;
2318             SP += items;
2319             if (CxTYPE(cx) == CXt_SUB &&
2320                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2321                 SvREFCNT_dec(cx->blk_sub.cv);
2322             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2323             LEAVE_SCOPE(oldsave);
2324
2325             /* Now do some callish stuff. */
2326             SAVETMPS;
2327             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2328             if (CvXSUB(cv)) {
2329                 if (reified) {
2330                     I32 index;
2331                     for (index=0; index<items; index++)
2332                         sv_2mortal(SP[-index]);
2333                 }
2334 #ifdef PERL_XSUB_OLDSTYLE
2335                 if (CvOLDSTYLE(cv)) {
2336                     I32 (*fp3)(int,int,int);
2337                     while (SP > mark) {
2338                         SP[1] = SP[0];
2339                         SP--;
2340                     }
2341                     fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2342                     items = (*fp3)(CvXSUBANY(cv).any_i32,
2343                                    mark - PL_stack_base + 1,
2344                                    items);
2345                     SP = PL_stack_base + items;
2346                 }
2347                 else
2348 #endif /* PERL_XSUB_OLDSTYLE */
2349                 {
2350                     SV **newsp;
2351                     I32 gimme;
2352
2353                     /* Push a mark for the start of arglist */
2354                     PUSHMARK(mark);
2355                     PUTBACK;
2356                     (void)(*CvXSUB(cv))(aTHX_ cv);
2357                     /* Pop the current context like a decent sub should */
2358                     POPBLOCK(cx, PL_curpm);
2359                     /* Do _not_ use PUTBACK, keep the XSUB's return stack! */
2360                 }
2361                 LEAVE;
2362                 assert(CxTYPE(cx) == CXt_SUB);
2363                 return cx->blk_sub.retop;
2364             }
2365             else {
2366                 AV* padlist = CvPADLIST(cv);
2367                 if (CxTYPE(cx) == CXt_EVAL) {
2368                     PL_in_eval = cx->blk_eval.old_in_eval;
2369                     PL_eval_root = cx->blk_eval.old_eval_root;
2370                     cx->cx_type = CXt_SUB;
2371                     cx->blk_sub.hasargs = 0;
2372                 }
2373                 cx->blk_sub.cv = cv;
2374                 cx->blk_sub.olddepth = (U16)CvDEPTH(cv);
2375
2376                 CvDEPTH(cv)++;
2377                 if (CvDEPTH(cv) < 2)
2378                     (void)SvREFCNT_inc(cv);
2379                 else {
2380                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2381                         sub_crush_depth(cv);
2382                     pad_push(padlist, CvDEPTH(cv));
2383                 }
2384                 PAD_SET_CUR(padlist, CvDEPTH(cv));
2385                 if (cx->blk_sub.hasargs)
2386                 {
2387                     AV* av = (AV*)PAD_SVl(0);
2388                     SV** ary;
2389
2390                     cx->blk_sub.savearray = GvAV(PL_defgv);
2391                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2392                     CX_CURPAD_SAVE(cx->blk_sub);
2393                     cx->blk_sub.argarray = av;
2394
2395                     if (items >= AvMAX(av) + 1) {
2396                         ary = AvALLOC(av);
2397                         if (AvARRAY(av) != ary) {
2398                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2399                             SvPV_set(av, (char*)ary);
2400                         }
2401                         if (items >= AvMAX(av) + 1) {
2402                             AvMAX(av) = items - 1;
2403                             Renew(ary,items+1,SV*);
2404                             AvALLOC(av) = ary;
2405                             SvPV_set(av, (char*)ary);
2406                         }
2407                     }
2408                     ++mark;
2409                     Copy(mark,AvARRAY(av),items,SV*);
2410                     AvFILLp(av) = items - 1;
2411                     assert(!AvREAL(av));
2412                     if (reified) {
2413                         /* transfer 'ownership' of refcnts to new @_ */
2414                         AvREAL_on(av);
2415                         AvREIFY_off(av);
2416                     }
2417                     while (items--) {
2418                         if (*mark)
2419                             SvTEMP_off(*mark);
2420                         mark++;
2421                     }
2422                 }
2423                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2424                     /*
2425                      * We do not care about using sv to call CV;
2426                      * it's for informational purposes only.
2427                      */
2428                     SV *sv = GvSV(PL_DBsub);
2429                     CV *gotocv;
2430
2431                     save_item(sv);
2432                     if (PERLDB_SUB_NN) {
2433                         int type = SvTYPE(sv);
2434                         if (type < SVt_PVIV && type != SVt_IV)
2435                             sv_upgrade(sv, SVt_PVIV);
2436                         (void)SvIOK_on(sv);
2437                         SvIV_set(sv, PTR2IV(cv)); /* Do it the quickest way */
2438                     } else {
2439                         gv_efullname3(sv, CvGV(cv), Nullch);
2440                     }
2441                     if (  PERLDB_GOTO
2442                           && (gotocv = get_cv("DB::goto", FALSE)) ) {
2443                         PUSHMARK( PL_stack_sp );
2444                         call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2445                         PL_stack_sp--;
2446                     }
2447                 }
2448                 RETURNOP(CvSTART(cv));
2449             }
2450         }
2451         else {
2452             label = SvPV(sv,n_a);
2453             if (!(do_dump || *label))
2454                 DIE(aTHX_ must_have_label);
2455         }
2456     }
2457     else if (PL_op->op_flags & OPf_SPECIAL) {
2458         if (! do_dump)
2459             DIE(aTHX_ must_have_label);
2460     }
2461     else
2462         label = cPVOP->op_pv;
2463
2464     if (label && *label) {
2465         OP *gotoprobe = 0;
2466         bool leaving_eval = FALSE;
2467         bool in_block = FALSE;
2468         PERL_CONTEXT *last_eval_cx = 0;
2469
2470         /* find label */
2471
2472         PL_lastgotoprobe = 0;
2473         *enterops = 0;
2474         for (ix = cxstack_ix; ix >= 0; ix--) {
2475             cx = &cxstack[ix];
2476             switch (CxTYPE(cx)) {
2477             case CXt_EVAL:
2478                 leaving_eval = TRUE;
2479                 if (!CxTRYBLOCK(cx)) {
2480                     gotoprobe = (last_eval_cx ?
2481                                 last_eval_cx->blk_eval.old_eval_root :
2482                                 PL_eval_root);
2483                     last_eval_cx = cx;
2484                     break;
2485                 }
2486                 /* else fall through */
2487             case CXt_LOOP:
2488                 gotoprobe = cx->blk_oldcop->op_sibling;
2489                 break;
2490             case CXt_SUBST:
2491                 continue;
2492             case CXt_BLOCK:
2493                 if (ix) {
2494                     gotoprobe = cx->blk_oldcop->op_sibling;
2495                     in_block = TRUE;
2496                 } else
2497                     gotoprobe = PL_main_root;
2498                 break;
2499             case CXt_SUB:
2500                 if (CvDEPTH(cx->blk_sub.cv)) {
2501                     gotoprobe = CvROOT(cx->blk_sub.cv);
2502                     break;
2503                 }
2504                 /* FALL THROUGH */
2505             case CXt_FORMAT:
2506             case CXt_NULL:
2507                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2508             default:
2509                 if (ix)
2510                     DIE(aTHX_ "panic: goto");
2511                 gotoprobe = PL_main_root;
2512                 break;
2513             }
2514             if (gotoprobe) {
2515                 retop = dofindlabel(gotoprobe, label,
2516                                     enterops, enterops + GOTO_DEPTH);
2517                 if (retop)
2518                     break;
2519             }
2520             PL_lastgotoprobe = gotoprobe;
2521         }
2522         if (!retop)
2523             DIE(aTHX_ "Can't find label %s", label);
2524
2525         /* if we're leaving an eval, check before we pop any frames
2526            that we're not going to punt, otherwise the error
2527            won't be caught */
2528
2529         if (leaving_eval && *enterops && enterops[1]) {
2530             I32 i;
2531             for (i = 1; enterops[i]; i++)
2532                 if (enterops[i]->op_type == OP_ENTERITER)
2533                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2534         }
2535
2536         /* pop unwanted frames */
2537
2538         if (ix < cxstack_ix) {
2539             I32 oldsave;
2540
2541             if (ix < 0)
2542                 ix = 0;
2543             dounwind(ix);
2544             TOPBLOCK(cx);
2545             oldsave = PL_scopestack[PL_scopestack_ix];
2546             LEAVE_SCOPE(oldsave);
2547         }
2548
2549         /* push wanted frames */
2550
2551         if (*enterops && enterops[1]) {
2552             OP *oldop = PL_op;
2553             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2554             for (; enterops[ix]; ix++) {
2555                 PL_op = enterops[ix];
2556                 /* Eventually we may want to stack the needed arguments
2557                  * for each op.  For now, we punt on the hard ones. */
2558                 if (PL_op->op_type == OP_ENTERITER)
2559                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2560                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2561             }
2562             PL_op = oldop;
2563         }
2564     }
2565
2566     if (do_dump) {
2567 #ifdef VMS
2568         if (!retop) retop = PL_main_start;
2569 #endif
2570         PL_restartop = retop;
2571         PL_do_undump = TRUE;
2572
2573         my_unexec();
2574
2575         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2576         PL_do_undump = FALSE;
2577     }
2578
2579     RETURNOP(retop);
2580 }
2581
2582 PP(pp_exit)
2583 {
2584     dSP;
2585     I32 anum;
2586
2587     if (MAXARG < 1)
2588         anum = 0;
2589     else {
2590         anum = SvIVx(POPs);
2591 #ifdef VMS
2592         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2593             anum = 0;
2594         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2595 #endif
2596     }
2597     PL_exit_flags |= PERL_EXIT_EXPECTED;
2598     my_exit(anum);
2599     PUSHs(&PL_sv_undef);
2600     RETURN;
2601 }
2602
2603 #ifdef NOTYET
2604 PP(pp_nswitch)
2605 {
2606     dSP;
2607     NV value = SvNVx(GvSV(cCOP->cop_gv));
2608     register I32 match = I_32(value);
2609
2610     if (value < 0.0) {
2611         if (((NV)match) > value)
2612             --match;            /* was fractional--truncate other way */
2613     }
2614     match -= cCOP->uop.scop.scop_offset;
2615     if (match < 0)
2616         match = 0;
2617     else if (match > cCOP->uop.scop.scop_max)
2618         match = cCOP->uop.scop.scop_max;
2619     PL_op = cCOP->uop.scop.scop_next[match];
2620     RETURNOP(PL_op);
2621 }
2622
2623 PP(pp_cswitch)
2624 {
2625     dSP;
2626     register I32 match;
2627
2628     if (PL_multiline)
2629         PL_op = PL_op->op_next;                 /* can't assume anything */
2630     else {
2631         STRLEN n_a;
2632         match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255;
2633         match -= cCOP->uop.scop.scop_offset;
2634         if (match < 0)
2635             match = 0;
2636         else if (match > cCOP->uop.scop.scop_max)
2637             match = cCOP->uop.scop.scop_max;
2638         PL_op = cCOP->uop.scop.scop_next[match];
2639     }
2640     RETURNOP(PL_op);
2641 }
2642 #endif
2643
2644 /* Eval. */
2645
2646 STATIC void
2647 S_save_lines(pTHX_ AV *array, SV *sv)
2648 {
2649     register const char *s = SvPVX(sv);
2650     register const char *send = SvPVX(sv) + SvCUR(sv);
2651     register const char *t;
2652     register I32 line = 1;
2653
2654     while (s && s < send) {
2655         SV *tmpstr = NEWSV(85,0);
2656
2657         sv_upgrade(tmpstr, SVt_PVMG);
2658         t = strchr(s, '\n');
2659         if (t)
2660             t++;
2661         else
2662             t = send;
2663
2664         sv_setpvn(tmpstr, s, t - s);
2665         av_store(array, line++, tmpstr);
2666         s = t;
2667     }
2668 }
2669
2670 STATIC void *
2671 S_docatch_body(pTHX)
2672 {
2673     CALLRUNOPS(aTHX);
2674     return NULL;
2675 }
2676
2677 STATIC OP *
2678 S_docatch(pTHX_ OP *o)
2679 {
2680     int ret;
2681     OP * const oldop = PL_op;
2682     OP *retop;
2683     volatile PERL_SI *cursi = PL_curstackinfo;
2684     dJMPENV;
2685
2686 #ifdef DEBUGGING
2687     assert(CATCH_GET == TRUE);
2688 #endif
2689     PL_op = o;
2690
2691     /* Normally, the leavetry at the end of this block of ops will
2692      * pop an op off the return stack and continue there. By setting
2693      * the op to Nullop, we force an exit from the inner runops()
2694      * loop. DAPM.
2695      */
2696     assert(cxstack_ix >= 0);
2697     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2698     retop = cxstack[cxstack_ix].blk_eval.retop;
2699     cxstack[cxstack_ix].blk_eval.retop = Nullop;
2700
2701     JMPENV_PUSH(ret);
2702     switch (ret) {
2703     case 0:
2704  redo_body:
2705         docatch_body();
2706         break;
2707     case 3:
2708         /* die caught by an inner eval - continue inner loop */
2709         if (PL_restartop && cursi == PL_curstackinfo) {
2710             PL_op = PL_restartop;
2711             PL_restartop = 0;
2712             goto redo_body;
2713         }
2714         /* a die in this eval - continue in outer loop */
2715         if (!PL_restartop)
2716             break;
2717         /* FALL THROUGH */
2718     default:
2719         JMPENV_POP;
2720         PL_op = oldop;
2721         JMPENV_JUMP(ret);
2722         /* NOTREACHED */
2723     }
2724     JMPENV_POP;
2725     PL_op = oldop;
2726     return retop;
2727 }
2728
2729 OP *
2730 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2731 /* sv Text to convert to OP tree. */
2732 /* startop op_free() this to undo. */
2733 /* code Short string id of the caller. */
2734 {
2735     dSP;                                /* Make POPBLOCK work. */
2736     PERL_CONTEXT *cx;
2737     SV **newsp;
2738     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
2739     I32 optype;
2740     OP dummy;
2741     OP *rop;
2742     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2743     char *tmpbuf = tbuf;
2744     char *safestr;
2745     int runtime;
2746     CV* runcv = Nullcv; /* initialise to avoid compiler warnings */
2747
2748     ENTER;
2749     lex_start(sv);
2750     SAVETMPS;
2751     /* switch to eval mode */
2752
2753     if (IN_PERL_COMPILETIME) {
2754         SAVECOPSTASH_FREE(&PL_compiling);
2755         CopSTASH_set(&PL_compiling, PL_curstash);
2756     }
2757     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2758         SV *sv = sv_newmortal();
2759         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2760                        code, (unsigned long)++PL_evalseq,
2761                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2762         tmpbuf = SvPVX(sv);
2763     }
2764     else
2765         sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
2766     SAVECOPFILE_FREE(&PL_compiling);
2767     CopFILE_set(&PL_compiling, tmpbuf+2);
2768     SAVECOPLINE(&PL_compiling);
2769     CopLINE_set(&PL_compiling, 1);
2770     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2771        deleting the eval's FILEGV from the stash before gv_check() runs
2772        (i.e. before run-time proper). To work around the coredump that
2773        ensues, we always turn GvMULTI_on for any globals that were
2774        introduced within evals. See force_ident(). GSAR 96-10-12 */
2775     safestr = savepv(tmpbuf);
2776     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
2777     SAVEHINTS();
2778 #ifdef OP_IN_REGISTER
2779     PL_opsave = op;
2780 #else
2781     SAVEVPTR(PL_op);
2782 #endif
2783
2784     /* we get here either during compilation, or via pp_regcomp at runtime */
2785     runtime = IN_PERL_RUNTIME;
2786     if (runtime)
2787         runcv = find_runcv(NULL);
2788
2789     PL_op = &dummy;
2790     PL_op->op_type = OP_ENTEREVAL;
2791     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2792     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2793     PUSHEVAL(cx, 0, Nullgv);
2794
2795     if (runtime)
2796         rop = doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2797     else
2798         rop = doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2799     POPBLOCK(cx,PL_curpm);
2800     POPEVAL(cx);
2801
2802     (*startop)->op_type = OP_NULL;
2803     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2804     lex_end();
2805     /* XXX DAPM do this properly one year */
2806     *padp = (AV*)SvREFCNT_inc(PL_comppad);
2807     LEAVE;
2808     if (IN_PERL_COMPILETIME)
2809         PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
2810 #ifdef OP_IN_REGISTER
2811     op = PL_opsave;
2812 #endif
2813     return rop;
2814 }
2815
2816
2817 /*
2818 =for apidoc find_runcv
2819
2820 Locate the CV corresponding to the currently executing sub or eval.
2821 If db_seqp is non_null, skip CVs that are in the DB package and populate
2822 *db_seqp with the cop sequence number at the point that the DB:: code was
2823 entered. (allows debuggers to eval in the scope of the breakpoint rather
2824 than in in the scope of the debugger itself).
2825
2826 =cut
2827 */
2828
2829 CV*
2830 Perl_find_runcv(pTHX_ U32 *db_seqp)
2831 {
2832     PERL_SI      *si;
2833
2834     if (db_seqp)
2835         *db_seqp = PL_curcop->cop_seq;
2836     for (si = PL_curstackinfo; si; si = si->si_prev) {
2837         I32 ix;
2838         for (ix = si->si_cxix; ix >= 0; ix--) {
2839             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2840             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2841                 CV *cv = cx->blk_sub.cv;
2842                 /* skip DB:: code */
2843                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2844                     *db_seqp = cx->blk_oldcop->cop_seq;
2845                     continue;
2846                 }
2847                 return cv;
2848             }
2849             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2850                 return PL_compcv;
2851         }
2852     }
2853     return PL_main_cv;
2854 }
2855
2856
2857 /* Compile a require/do, an eval '', or a /(?{...})/.
2858  * In the last case, startop is non-null, and contains the address of
2859  * a pointer that should be set to the just-compiled code.
2860  * outside is the lexically enclosing CV (if any) that invoked us.
2861  */
2862
2863 /* With USE_5005THREADS, eval_owner must be held on entry to doeval */
2864 STATIC OP *
2865 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2866 {
2867     dSP;
2868     OP *saveop = PL_op;
2869
2870     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2871                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2872                   : EVAL_INEVAL);
2873
2874     PUSHMARK(SP);
2875
2876     SAVESPTR(PL_compcv);
2877     PL_compcv = (CV*)NEWSV(1104,0);
2878     sv_upgrade((SV *)PL_compcv, SVt_PVCV);
2879     CvEVAL_on(PL_compcv);
2880     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2881     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2882
2883     CvOUTSIDE_SEQ(PL_compcv) = seq;
2884     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outside);
2885
2886     /* set up a scratch pad */
2887
2888     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2889
2890
2891     SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
2892
2893     /* make sure we compile in the right package */
2894
2895     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2896         SAVESPTR(PL_curstash);
2897         PL_curstash = CopSTASH(PL_curcop);
2898     }
2899     SAVESPTR(PL_beginav);
2900     PL_beginav = newAV();
2901     SAVEFREESV(PL_beginav);
2902     SAVEI32(PL_error_count);
2903
2904     /* try to compile it */
2905
2906     PL_eval_root = Nullop;
2907     PL_error_count = 0;
2908     PL_curcop = &PL_compiling;
2909     PL_curcop->cop_arybase = 0;
2910     if (saveop && saveop->op_flags & OPf_SPECIAL)
2911         PL_in_eval |= EVAL_KEEPERR;
2912     else
2913         sv_setpv(ERRSV,"");
2914     if (yyparse() || PL_error_count || !PL_eval_root) {
2915         SV **newsp;                     /* Used by POPBLOCK. */
2916        PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2917         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2918         STRLEN n_a;
2919
2920         PL_op = saveop;
2921         if (PL_eval_root) {
2922             op_free(PL_eval_root);
2923             PL_eval_root = Nullop;
2924         }
2925         SP = PL_stack_base + POPMARK;           /* pop original mark */
2926         if (!startop) {
2927             POPBLOCK(cx,PL_curpm);
2928             POPEVAL(cx);
2929         }
2930         lex_end();
2931         LEAVE;
2932         if (optype == OP_REQUIRE) {
2933             const char* msg = SvPVx(ERRSV, n_a);
2934            SV *nsv = cx->blk_eval.old_namesv;
2935            (void)hv_store(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv),
2936                           &PL_sv_undef, 0);
2937             DIE(aTHX_ "%sCompilation failed in require",
2938                 *msg ? msg : "Unknown error\n");
2939         }
2940         else if (startop) {
2941             const char* msg = SvPVx(ERRSV, n_a);
2942
2943             POPBLOCK(cx,PL_curpm);
2944             POPEVAL(cx);
2945             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2946                        (*msg ? msg : "Unknown error\n"));
2947         }
2948         else {
2949             const char* msg = SvPVx(ERRSV, n_a);
2950             if (!*msg) {
2951                 sv_setpv(ERRSV, "Compilation error");
2952             }
2953         }
2954         RETPUSHUNDEF;
2955     }
2956     CopLINE_set(&PL_compiling, 0);
2957     if (startop) {
2958         *startop = PL_eval_root;
2959     } else
2960         SAVEFREEOP(PL_eval_root);
2961
2962     /* Set the context for this new optree.
2963      * If the last op is an OP_REQUIRE, force scalar context.
2964      * Otherwise, propagate the context from the eval(). */
2965     if (PL_eval_root->op_type == OP_LEAVEEVAL
2966             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2967             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2968             == OP_REQUIRE)
2969         scalar(PL_eval_root);
2970     else if (gimme & G_VOID)
2971         scalarvoid(PL_eval_root);
2972     else if (gimme & G_ARRAY)
2973         list(PL_eval_root);
2974     else
2975         scalar(PL_eval_root);
2976
2977     DEBUG_x(dump_eval());
2978
2979     /* Register with debugger: */
2980     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
2981         CV *cv = get_cv("DB::postponed", FALSE);
2982         if (cv) {
2983             dSP;
2984             PUSHMARK(SP);
2985             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2986             PUTBACK;
2987             call_sv((SV*)cv, G_DISCARD);
2988         }
2989     }
2990
2991     /* compiled okay, so do it */
2992
2993     CvDEPTH(PL_compcv) = 1;
2994     SP = PL_stack_base + POPMARK;               /* pop original mark */
2995     PL_op = saveop;                     /* The caller may need it. */
2996     PL_lex_state = LEX_NOTPARSING;      /* $^S needs this. */
2997
2998     RETURNOP(PL_eval_start);
2999 }
3000
3001 STATIC PerlIO *
3002 S_doopen_pm(pTHX_ const char *name, const char *mode)
3003 {
3004 #ifndef PERL_DISABLE_PMC
3005     STRLEN namelen = strlen(name);
3006     PerlIO *fp;
3007
3008     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3009         SV *pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3010         const char * const pmc = SvPV_nolen(pmcsv);
3011         Stat_t pmstat;
3012         Stat_t pmcstat;
3013         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3014             fp = PerlIO_open(name, mode);
3015         }
3016         else {
3017             if (PerlLIO_stat(name, &pmstat) < 0 ||
3018                 pmstat.st_mtime < pmcstat.st_mtime)
3019             {
3020                 fp = PerlIO_open(pmc, mode);
3021             }
3022             else {
3023                 fp = PerlIO_open(name, mode);
3024             }
3025         }
3026         SvREFCNT_dec(pmcsv);
3027     }
3028     else {
3029         fp = PerlIO_open(name, mode);
3030     }
3031     return fp;
3032 #else
3033     return PerlIO_open(name, mode);
3034 #endif /* !PERL_DISABLE_PMC */
3035 }
3036
3037 PP(pp_require)
3038 {
3039     dSP;
3040     register PERL_CONTEXT *cx;
3041     SV *sv;
3042     char *name;
3043     STRLEN len;
3044     char *tryname = Nullch;
3045     SV *namesv = Nullsv;
3046     SV** svp;
3047     I32 gimme = GIMME_V;
3048     PerlIO *tryrsfp = 0;
3049     STRLEN n_a;
3050     int filter_has_file = 0;
3051     GV *filter_child_proc = 0;
3052     SV *filter_state = 0;
3053     SV *filter_sub = 0;
3054     SV *hook_sv = 0;
3055     SV *encoding;
3056     OP *op;
3057
3058     sv = POPs;
3059     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3060         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) )       /* require v5.6.1 */
3061                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3062                         "v-string in use/require non-portable");
3063
3064         sv = new_version(sv);
3065         if (!sv_derived_from(PL_patchlevel, "version"))
3066             (void *)upg_version(PL_patchlevel);
3067         if ( vcmp(sv,PL_patchlevel) > 0 )
3068             DIE(aTHX_ "Perl v%"SVf" required--this is only v%"SVf", stopped",
3069                 vstringify(sv), vstringify(PL_patchlevel));
3070
3071             RETPUSHYES;
3072     }
3073     name = SvPV(sv, len);
3074     if (!(name && len > 0 && *name))
3075         DIE(aTHX_ "Null filename used");
3076     TAINT_PROPER("require");
3077     if (PL_op->op_type == OP_REQUIRE &&
3078        (svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3079        if (*svp != &PL_sv_undef)
3080            RETPUSHYES;
3081        else
3082            DIE(aTHX_ "Compilation failed in require");
3083     }
3084
3085     /* prepare to compile file */
3086
3087     if (path_is_absolute(name)) {
3088         tryname = name;
3089         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3090     }
3091 #ifdef MACOS_TRADITIONAL
3092     if (!tryrsfp) {
3093         char newname[256];
3094
3095         MacPerl_CanonDir(name, newname, 1);
3096         if (path_is_absolute(newname)) {
3097             tryname = newname;
3098             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3099         }
3100     }
3101 #endif
3102     if (!tryrsfp) {
3103         AV *ar = GvAVn(PL_incgv);
3104         I32 i;
3105 #ifdef VMS
3106         char *unixname;
3107         if ((unixname = tounixspec(name, Nullch)) != Nullch)
3108 #endif
3109         {
3110             namesv = NEWSV(806, 0);
3111             for (i = 0; i <= AvFILL(ar); i++) {
3112                 SV *dirsv = *av_fetch(ar, i, TRUE);
3113
3114                 if (SvROK(dirsv)) {
3115                     int count;
3116                     SV *loader = dirsv;
3117
3118                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3119                         && !sv_isobject(loader))
3120                     {
3121                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3122                     }
3123
3124                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3125                                    PTR2UV(SvRV(dirsv)), name);
3126                     tryname = SvPVX(namesv);
3127                     tryrsfp = 0;
3128
3129                     ENTER;
3130                     SAVETMPS;
3131                     EXTEND(SP, 2);
3132
3133                     PUSHMARK(SP);
3134                     PUSHs(dirsv);
3135                     PUSHs(sv);
3136                     PUTBACK;
3137                     if (sv_isobject(loader))
3138                         count = call_method("INC", G_ARRAY);
3139                     else
3140                         count = call_sv(loader, G_ARRAY);
3141                     SPAGAIN;
3142
3143                     if (count > 0) {
3144                         int i = 0;
3145                         SV *arg;
3146
3147                         SP -= count - 1;
3148                         arg = SP[i++];
3149
3150                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3151                             arg = SvRV(arg);
3152                         }
3153
3154                         if (SvTYPE(arg) == SVt_PVGV) {
3155                             IO *io = GvIO((GV *)arg);
3156
3157                             ++filter_has_file;
3158
3159                             if (io) {
3160                                 tryrsfp = IoIFP(io);
3161                                 if (IoTYPE(io) == IoTYPE_PIPE) {
3162                                     /* reading from a child process doesn't
3163                                        nest -- when returning from reading
3164                                        the inner module, the outer one is
3165                                        unreadable (closed?)  I've tried to
3166                                        save the gv to manage the lifespan of
3167                                        the pipe, but this didn't help. XXX */
3168                                     filter_child_proc = (GV *)arg;
3169                                     (void)SvREFCNT_inc(filter_child_proc);
3170                                 }
3171                                 else {
3172                                     if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3173                                         PerlIO_close(IoOFP(io));
3174                                     }
3175                                     IoIFP(io) = Nullfp;
3176                                     IoOFP(io) = Nullfp;
3177                                 }
3178                             }
3179
3180                             if (i < count) {
3181                                 arg = SP[i++];
3182                             }
3183                         }
3184
3185                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3186                             filter_sub = arg;
3187                             (void)SvREFCNT_inc(filter_sub);
3188
3189                             if (i < count) {
3190                                 filter_state = SP[i];
3191                                 (void)SvREFCNT_inc(filter_state);
3192                             }
3193
3194                             if (tryrsfp == 0) {
3195                                 tryrsfp = PerlIO_open("/dev/null",
3196                                                       PERL_SCRIPT_MODE);
3197                             }
3198                         }
3199                         SP--;
3200                     }
3201
3202                     PUTBACK;
3203                     FREETMPS;
3204                     LEAVE;
3205
3206                     if (tryrsfp) {
3207                         hook_sv = dirsv;
3208                         break;
3209                     }
3210
3211                     filter_has_file = 0;
3212                     if (filter_child_proc) {
3213                         SvREFCNT_dec(filter_child_proc);
3214                         filter_child_proc = 0;
3215                     }
3216                     if (filter_state) {
3217                         SvREFCNT_dec(filter_state);
3218                         filter_state = 0;
3219                     }
3220                     if (filter_sub) {
3221                         SvREFCNT_dec(filter_sub);
3222                         filter_sub = 0;
3223                     }
3224                 }
3225                 else {
3226                   if (!path_is_absolute(name)
3227 #ifdef MACOS_TRADITIONAL
3228                         /* We consider paths of the form :a:b ambiguous and interpret them first
3229                            as global then as local
3230                         */
3231                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3232 #endif
3233                   ) {
3234                     char *dir = SvPVx(dirsv, n_a);
3235 #ifdef MACOS_TRADITIONAL
3236                     char buf1[256];
3237                     char buf2[256];
3238
3239                     MacPerl_CanonDir(name, buf2, 1);
3240                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3241 #else
3242 #ifdef VMS
3243                     char *unixdir;
3244                     if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
3245                         continue;
3246                     sv_setpv(namesv, unixdir);
3247                     sv_catpv(namesv, unixname);
3248 #else
3249                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3250 #endif
3251 #endif
3252                     TAINT_PROPER("require");
3253                     tryname = SvPVX(namesv);
3254                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3255                     if (tryrsfp) {
3256                         if (tryname[0] == '.' && tryname[1] == '/')
3257                             tryname += 2;
3258                         break;
3259                     }
3260                   }
3261                 }
3262             }
3263         }
3264     }
3265     SAVECOPFILE_FREE(&PL_compiling);
3266     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3267     SvREFCNT_dec(namesv);
3268     if (!tryrsfp) {
3269         if (PL_op->op_type == OP_REQUIRE) {
3270             char *msgstr = name;
3271             if (namesv) {                       /* did we lookup @INC? */
3272                 SV *msg = sv_2mortal(newSVpv(msgstr,0));
3273                 SV *dirmsgsv = NEWSV(0, 0);
3274                 AV *ar = GvAVn(PL_incgv);
3275                 I32 i;
3276                 sv_catpvn(msg, " in @INC", 8);
3277                 if (instr(SvPVX(msg), ".h "))
3278                     sv_catpv(msg, " (change .h to .ph maybe?)");
3279                 if (instr(SvPVX(msg), ".ph "))
3280                     sv_catpv(msg, " (did you run h2ph?)");
3281                 sv_catpv(msg, " (@INC contains:");
3282                 for (i = 0; i <= AvFILL(ar); i++) {
3283                     char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a);
3284                     Perl_sv_setpvf(aTHX_ dirmsgsv, " %s", dir);
3285                     sv_catsv(msg, dirmsgsv);
3286                 }
3287                 sv_catpvn(msg, ")", 1);
3288                 SvREFCNT_dec(dirmsgsv);
3289                 msgstr = SvPV_nolen(msg);
3290             }
3291             DIE(aTHX_ "Can't locate %s", msgstr);
3292         }
3293
3294         RETPUSHUNDEF;
3295     }
3296     else
3297         SETERRNO(0, SS_NORMAL);
3298
3299     /* Assume success here to prevent recursive requirement. */
3300     len = strlen(name);
3301     /* Check whether a hook in @INC has already filled %INC */
3302     if (!hook_sv || !(svp = hv_fetch(GvHVn(PL_incgv), name, len, 0))) {
3303         (void)hv_store(GvHVn(PL_incgv), name, len,
3304                        (hook_sv ? SvREFCNT_inc(hook_sv)
3305                                 : newSVpv(CopFILE(&PL_compiling), 0)),
3306                        0 );
3307     }
3308
3309     ENTER;
3310     SAVETMPS;
3311     lex_start(sv_2mortal(newSVpvn("",0)));
3312     SAVEGENERICSV(PL_rsfp_filters);
3313     PL_rsfp_filters = Nullav;
3314
3315     PL_rsfp = tryrsfp;
3316     SAVEHINTS();
3317     PL_hints = 0;
3318     SAVESPTR(PL_compiling.cop_warnings);
3319     if (PL_dowarn & G_WARN_ALL_ON)
3320         PL_compiling.cop_warnings = pWARN_ALL ;
3321     else if (PL_dowarn & G_WARN_ALL_OFF)
3322         PL_compiling.cop_warnings = pWARN_NONE ;
3323     else if (PL_taint_warn)
3324         PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
3325     else
3326         PL_compiling.cop_warnings = pWARN_STD ;
3327     SAVESPTR(PL_compiling.cop_io);
3328     PL_compiling.cop_io = Nullsv;
3329
3330     if (filter_sub || filter_child_proc) {
3331         SV *datasv = filter_add(run_user_filter, Nullsv);
3332         IoLINES(datasv) = filter_has_file;
3333         IoFMT_GV(datasv) = (GV *)filter_child_proc;
3334         IoTOP_GV(datasv) = (GV *)filter_state;
3335         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3336     }
3337
3338     /* switch to eval mode */
3339     PUSHBLOCK(cx, CXt_EVAL, SP);
3340     PUSHEVAL(cx, name, Nullgv);
3341     cx->blk_eval.retop = PL_op->op_next;
3342
3343     SAVECOPLINE(&PL_compiling);
3344     CopLINE_set(&PL_compiling, 0);
3345
3346     PUTBACK;
3347
3348     /* Store and reset encoding. */
3349     encoding = PL_encoding;
3350     PL_encoding = Nullsv;
3351
3352     op = DOCATCH(doeval(gimme, NULL, Nullcv, PL_curcop->cop_seq));
3353
3354     /* Restore encoding. */
3355     PL_encoding = encoding;
3356
3357     return op;
3358 }
3359
3360 PP(pp_dofile)
3361 {
3362     return pp_require();
3363 }
3364
3365 PP(pp_entereval)
3366 {
3367     dSP;
3368     register PERL_CONTEXT *cx;
3369     dPOPss;
3370     I32 gimme = GIMME_V, was = PL_sub_generation;
3371     char tbuf[TYPE_DIGITS(long) + 12];
3372     char *tmpbuf = tbuf;
3373     char *safestr;
3374     STRLEN len;
3375     OP *ret;
3376     CV* runcv;
3377     U32 seq;
3378
3379     if (!SvPV(sv,len))
3380         RETPUSHUNDEF;
3381     TAINT_PROPER("eval");
3382
3383     ENTER;
3384     lex_start(sv);
3385     SAVETMPS;
3386
3387     /* switch to eval mode */
3388
3389     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3390         SV *sv = sv_newmortal();
3391         Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
3392                        (unsigned long)++PL_evalseq,
3393                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3394         tmpbuf = SvPVX(sv);
3395     }
3396     else
3397         sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
3398     SAVECOPFILE_FREE(&PL_compiling);
3399     CopFILE_set(&PL_compiling, tmpbuf+2);
3400     SAVECOPLINE(&PL_compiling);
3401     CopLINE_set(&PL_compiling, 1);
3402     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3403        deleting the eval's FILEGV from the stash before gv_check() runs
3404        (i.e. before run-time proper). To work around the coredump that
3405        ensues, we always turn GvMULTI_on for any globals that were
3406        introduced within evals. See force_ident(). GSAR 96-10-12 */
3407     safestr = savepv(tmpbuf);
3408     SAVEDELETE(PL_defstash, safestr, strlen(safestr));
3409     SAVEHINTS();
3410     PL_hints = PL_op->op_targ;
3411     SAVESPTR(PL_compiling.cop_warnings);
3412     if (specialWARN(PL_curcop->cop_warnings))
3413         PL_compiling.cop_warnings = PL_curcop->cop_warnings;
3414     else {
3415         PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
3416         SAVEFREESV(PL_compiling.cop_warnings);
3417     }
3418     SAVESPTR(PL_compiling.cop_io);
3419     if (specialCopIO(PL_curcop->cop_io))
3420         PL_compiling.cop_io = PL_curcop->cop_io;
3421     else {
3422         PL_compiling.cop_io = newSVsv(PL_curcop->cop_io);
3423         SAVEFREESV(PL_compiling.cop_io);
3424     }
3425     /* special case: an eval '' executed within the DB package gets lexically
3426      * placed in the first non-DB CV rather than the current CV - this
3427      * allows the debugger to execute code, find lexicals etc, in the
3428      * scope of the code being debugged. Passing &seq gets find_runcv
3429      * to do the dirty work for us */
3430     runcv = find_runcv(&seq);
3431
3432     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3433     PUSHEVAL(cx, 0, Nullgv);
3434     cx->blk_eval.retop = PL_op->op_next;
3435
3436     /* prepare to compile string */
3437
3438     if (PERLDB_LINE && PL_curstash != PL_debstash)
3439         save_lines(CopFILEAV(&PL_compiling), PL_linestr);
3440     PUTBACK;
3441     ret = doeval(gimme, NULL, runcv, seq);
3442     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3443         && ret != PL_op->op_next) {     /* Successive compilation. */
3444         strcpy(safestr, "_<(eval )");   /* Anything fake and short. */
3445     }
3446     return DOCATCH(ret);
3447 }
3448
3449 PP(pp_leaveeval)
3450 {
3451     dSP;
3452     register SV **mark;
3453     SV **newsp;
3454     PMOP *newpm;
3455     I32 gimme;
3456     register PERL_CONTEXT *cx;
3457     OP *retop;
3458     const U8 save_flags = PL_op -> op_flags;
3459     I32 optype;
3460
3461     POPBLOCK(cx,newpm);
3462     POPEVAL(cx);
3463     retop = cx->blk_eval.retop;
3464
3465     TAINT_NOT;
3466     if (gimme == G_VOID)
3467         MARK = newsp;
3468     else if (gimme == G_SCALAR) {
3469         MARK = newsp + 1;
3470         if (MARK <= SP) {
3471             if (SvFLAGS(TOPs) & SVs_TEMP)
3472                 *MARK = TOPs;
3473             else
3474                 *MARK = sv_mortalcopy(TOPs);
3475         }
3476         else {
3477             MEXTEND(mark,0);
3478             *MARK = &PL_sv_undef;
3479         }
3480         SP = MARK;
3481     }
3482     else {
3483         /* in case LEAVE wipes old return values */
3484         for (mark = newsp + 1; mark <= SP; mark++) {
3485             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3486                 *mark = sv_mortalcopy(*mark);
3487                 TAINT_NOT;      /* Each item is independent */
3488             }
3489         }
3490     }
3491     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3492
3493 #ifdef DEBUGGING
3494     assert(CvDEPTH(PL_compcv) == 1);
3495 #endif
3496     CvDEPTH(PL_compcv) = 0;
3497     lex_end();
3498
3499     if (optype == OP_REQUIRE &&
3500         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3501     {
3502         /* Unassume the success we assumed earlier. */
3503         SV *nsv = cx->blk_eval.old_namesv;
3504         (void)hv_delete(GvHVn(PL_incgv), SvPVX(nsv), SvCUR(nsv), G_DISCARD);
3505         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv);
3506         /* die_where() did LEAVE, or we won't be here */
3507     }
3508     else {
3509         LEAVE;
3510         if (!(save_flags & OPf_SPECIAL))
3511             sv_setpv(ERRSV,"");
3512     }
3513
3514     RETURNOP(retop);
3515 }
3516
3517 PP(pp_entertry)
3518 {
3519     dSP;
3520     register PERL_CONTEXT *cx;
3521     I32 gimme = GIMME_V;
3522
3523     ENTER;
3524     SAVETMPS;
3525
3526     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
3527     PUSHEVAL(cx, 0, 0);
3528     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3529
3530     PL_in_eval = EVAL_INEVAL;
3531     sv_setpv(ERRSV,"");
3532     PUTBACK;
3533     return DOCATCH(PL_op->op_next);
3534 }
3535
3536 PP(pp_leavetry)
3537 {
3538     dSP;
3539     register SV **mark;
3540     SV **newsp;
3541     PMOP *newpm;
3542     OP* retop;
3543     I32 gimme;
3544     register PERL_CONTEXT *cx;
3545     I32 optype;
3546
3547     POPBLOCK(cx,newpm);
3548     POPEVAL(cx);
3549     retop = cx->blk_eval.retop;
3550
3551     TAINT_NOT;
3552     if (gimme == G_VOID)
3553         SP = newsp;
3554     else if (gimme == G_SCALAR) {
3555         MARK = newsp + 1;
3556         if (MARK <= SP) {
3557             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3558                 *MARK = TOPs;
3559             else
3560                 *MARK = sv_mortalcopy(TOPs);
3561         }
3562         else {
3563             MEXTEND(mark,0);
3564             *MARK = &PL_sv_undef;
3565         }
3566         SP = MARK;
3567     }
3568     else {
3569         /* in case LEAVE wipes old return values */
3570         for (mark = newsp + 1; mark <= SP; mark++) {
3571             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3572                 *mark = sv_mortalcopy(*mark);
3573                 TAINT_NOT;      /* Each item is independent */
3574             }
3575         }
3576     }
3577     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3578
3579     LEAVE;
3580     sv_setpv(ERRSV,"");
3581     RETURNOP(retop);
3582 }
3583
3584 STATIC OP *
3585 S_doparseform(pTHX_ SV *sv)
3586 {
3587     STRLEN len;
3588     register char *s = SvPV_force(sv, len);
3589     register char *send = s + len;
3590     register char *base = Nullch;
3591     register I32 skipspaces = 0;
3592     bool noblank   = FALSE;
3593     bool repeat    = FALSE;
3594     bool postspace = FALSE;
3595     U32 *fops;
3596     register U32 *fpc;
3597     U32 *linepc = 0;
3598     register I32 arg;
3599     bool ischop;
3600     bool unchopnum = FALSE;
3601     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
3602
3603     if (len == 0)
3604         Perl_croak(aTHX_ "Null picture in formline");
3605
3606     /* estimate the buffer size needed */
3607     for (base = s; s <= send; s++) {
3608         if (*s == '\n' || *s == '@' || *s == '^')
3609             maxops += 10;
3610     }
3611     s = base;
3612     base = Nullch;
3613
3614     New(804, fops, maxops, U32);
3615     fpc = fops;
3616
3617     if (s < send) {
3618         linepc = fpc;
3619         *fpc++ = FF_LINEMARK;
3620         noblank = repeat = FALSE;
3621         base = s;
3622     }
3623
3624     while (s <= send) {
3625         switch (*s++) {
3626         default:
3627             skipspaces = 0;
3628             continue;
3629
3630         case '~':
3631             if (*s == '~') {
3632                 repeat = TRUE;
3633                 *s = ' ';
3634             }
3635             noblank = TRUE;
3636             s[-1] = ' ';
3637             /* FALL THROUGH */
3638         case ' ': case '\t':
3639             skipspaces++;
3640             continue;
3641         case 0:
3642             if (s < send) {
3643                 skipspaces = 0;
3644                 continue;
3645             } /* else FALL THROUGH */
3646         case '\n':
3647             arg = s - base;
3648             skipspaces++;
3649             arg -= skipspaces;
3650             if (arg) {
3651                 if (postspace)
3652                     *fpc++ = FF_SPACE;
3653                 *fpc++ = FF_LITERAL;
3654                 *fpc++ = (U16)arg;
3655             }
3656             postspace = FALSE;
3657             if (s <= send)
3658                 skipspaces--;
3659             if (skipspaces) {
3660                 *fpc++ = FF_SKIP;
3661                 *fpc++ = (U16)skipspaces;
3662             }
3663             skipspaces = 0;
3664             if (s <= send)
3665                 *fpc++ = FF_NEWLINE;
3666             if (noblank) {
3667                 *fpc++ = FF_BLANK;
3668                 if (repeat)
3669                     arg = fpc - linepc + 1;
3670                 else
3671                     arg = 0;
3672                 *fpc++ = (U16)arg;
3673             }
3674             if (s < send) {
3675                 linepc = fpc;
3676                 *fpc++ = FF_LINEMARK;
3677                 noblank = repeat = FALSE;
3678                 base = s;
3679             }
3680             else
3681                 s++;
3682             continue;
3683
3684         case '@':
3685         case '^':
3686             ischop = s[-1] == '^';
3687
3688             if (postspace) {
3689                 *fpc++ = FF_SPACE;
3690                 postspace = FALSE;
3691             }
3692             arg = (s - base) - 1;
3693             if (arg) {
3694                 *fpc++ = FF_LITERAL;
3695                 *fpc++ = (U16)arg;
3696             }
3697
3698             base = s - 1;
3699             *fpc++ = FF_FETCH;
3700             if (*s == '*') {
3701                 s++;
3702                 *fpc++ = 2;  /* skip the @* or ^* */
3703                 if (ischop) {
3704                     *fpc++ = FF_LINESNGL;
3705                     *fpc++ = FF_CHOP;
3706                 } else
3707                     *fpc++ = FF_LINEGLOB;
3708             }
3709             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
3710                 arg = ischop ? 512 : 0;
3711                 base = s - 1;
3712                 while (*s == '#')
3713                     s++;
3714                 if (*s == '.') {
3715                     const char * const f = ++s;
3716                     while (*s == '#')
3717                         s++;
3718                     arg |= 256 + (s - f);
3719                 }
3720                 *fpc++ = s - base;              /* fieldsize for FETCH */
3721                 *fpc++ = FF_DECIMAL;
3722                 *fpc++ = (U16)arg;
3723                 unchopnum |= ! ischop;
3724             }
3725             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
3726                 arg = ischop ? 512 : 0;
3727                 base = s - 1;
3728                 s++;                                /* skip the '0' first */
3729                 while (*s == '#')
3730                     s++;
3731                 if (*s == '.') {
3732                     const char * const f = ++s;
3733                     while (*s == '#')
3734                         s++;
3735                     arg |= 256 + (s - f);
3736                 }
3737                 *fpc++ = s - base;                /* fieldsize for FETCH */
3738                 *fpc++ = FF_0DECIMAL;
3739                 *fpc++ = (U16)arg;
3740                 unchopnum |= ! ischop;
3741             }
3742             else {
3743                 I32 prespace = 0;
3744                 bool ismore = FALSE;
3745
3746                 if (*s == '>') {
3747                     while (*++s == '>') ;
3748                     prespace = FF_SPACE;
3749                 }
3750                 else if (*s == '|') {
3751                     while (*++s == '|') ;
3752                     prespace = FF_HALFSPACE;
3753                     postspace = TRUE;
3754                 }
3755                 else {
3756                     if (*s == '<')
3757                         while (*++s == '<') ;
3758                     postspace = TRUE;
3759                 }
3760                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
3761                     s += 3;
3762                     ismore = TRUE;
3763                 }
3764                 *fpc++ = s - base;              /* fieldsize for FETCH */
3765
3766                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
3767
3768                 if (prespace)
3769                     *fpc++ = (U16)prespace;
3770                 *fpc++ = FF_ITEM;
3771                 if (ismore)
3772                     *fpc++ = FF_MORE;
3773                 if (ischop)
3774                     *fpc++ = FF_CHOP;
3775             }
3776             base = s;
3777             skipspaces = 0;
3778             continue;
3779         }
3780     }
3781     *fpc++ = FF_END;
3782
3783     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
3784     arg = fpc - fops;
3785     { /* need to jump to the next word */
3786         int z;
3787         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
3788         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
3789         s = SvPVX(sv) + SvCUR(sv) + z;
3790     }
3791     Copy(fops, s, arg, U32);
3792     Safefree(fops);
3793     sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
3794     SvCOMPILED_on(sv);
3795
3796     if (unchopnum && repeat)
3797         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
3798     return 0;
3799 }
3800
3801
3802 STATIC bool
3803 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
3804 {
3805     /* Can value be printed in fldsize chars, using %*.*f ? */
3806     NV pwr = 1;
3807     NV eps = 0.5;
3808     bool res = FALSE;
3809     int intsize = fldsize - (value < 0 ? 1 : 0);
3810
3811     if (frcsize & 256)
3812         intsize--;
3813     frcsize &= 255;
3814     intsize -= frcsize;
3815
3816     while (intsize--) pwr *= 10.0;
3817     while (frcsize--) eps /= 10.0;
3818
3819     if( value >= 0 ){
3820         if (value + eps >= pwr)
3821             res = TRUE;
3822     } else {
3823         if (value - eps <= -pwr)
3824             res = TRUE;
3825     }
3826     return res;
3827 }
3828
3829 static I32
3830 run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
3831 {
3832     SV *datasv = FILTER_DATA(idx);
3833     int filter_has_file = IoLINES(datasv);
3834     GV *filter_child_proc = (GV *)IoFMT_GV(datasv);
3835     SV *filter_state = (SV *)IoTOP_GV(datasv);
3836     SV *filter_sub = (SV *)IoBOTTOM_GV(datasv);
3837     int len = 0;
3838
3839     /* I was having segfault trouble under Linux 2.2.5 after a
3840        parse error occured.  (Had to hack around it with a test
3841        for PL_error_count == 0.)  Solaris doesn't segfault --
3842        not sure where the trouble is yet.  XXX */
3843
3844     if (filter_has_file) {
3845         len = FILTER_READ(idx+1, buf_sv, maxlen);
3846     }
3847
3848     if (filter_sub && len >= 0) {
3849         dSP;
3850         int count;
3851
3852         ENTER;
3853         SAVE_DEFSV;
3854         SAVETMPS;
3855         EXTEND(SP, 2);
3856
3857         DEFSV = buf_sv;
3858         PUSHMARK(SP);
3859         PUSHs(sv_2mortal(newSViv(maxlen)));
3860         if (filter_state) {
3861             PUSHs(filter_state);
3862         }
3863         PUTBACK;
3864         count = call_sv(filter_sub, G_SCALAR);
3865         SPAGAIN;
3866
3867         if (count > 0) {
3868             SV *out = POPs;
3869             if (SvOK(out)) {
3870                 len = SvIV(out);
3871             }
3872         }
3873
3874         PUTBACK;
3875         FREETMPS;
3876         LEAVE;
3877     }
3878
3879     if (len <= 0) {
3880         IoLINES(datasv) = 0;
3881         if (filter_child_proc) {
3882             SvREFCNT_dec(filter_child_proc);
3883             IoFMT_GV(datasv) = Nullgv;
3884         }
3885         if (filter_state) {
3886             SvREFCNT_dec(filter_state);
3887             IoTOP_GV(datasv) = Nullgv;
3888         }
3889         if (filter_sub) {
3890             SvREFCNT_dec(filter_sub);
3891             IoBOTTOM_GV(datasv) = Nullgv;
3892         }
3893         filter_del(run_user_filter);
3894     }
3895
3896     return len;
3897 }
3898
3899 /* perhaps someone can come up with a better name for
3900    this?  it is not really "absolute", per se ... */
3901 static bool
3902 S_path_is_absolute(pTHX_ const char *name)
3903 {
3904     if (PERL_FILE_IS_ABSOLUTE(name)
3905 #ifdef MACOS_TRADITIONAL
3906         || (*name == ':'))
3907 #else
3908         || (*name == '.' && (name[1] == '/' ||
3909                              (name[1] == '.' && name[2] == '/'))))
3910 #endif
3911     {
3912         return TRUE;
3913     }
3914     else
3915         return FALSE;
3916 }
3917
3918 /*
3919  * Local variables:
3920  * c-indentation-style: bsd
3921  * c-basic-offset: 4
3922  * indent-tabs-mode: t
3923  * End:
3924  *
3925  * vim: shiftwidth=4:
3926 */