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