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, 2006, 2007 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 #define dopoptosub(plop)        dopoptosub_at(cxstack, (plop))
  42
  43 PP(pp_wantarray)
  44 {
  45     dVAR;
  46     dSP;
  47     I32 cxix;
  48     EXTEND(SP, 1);
  49
  50     cxix = dopoptosub(cxstack_ix);
  51     if (cxix < 0)
  52         RETPUSHUNDEF;
  53
  54     switch (cxstack[cxix].blk_gimme) {
  55     case G_ARRAY:
  56         RETPUSHYES;
  57     case G_SCALAR:
  58         RETPUSHNO;
  59     default:
  60         RETPUSHUNDEF;
  61     }
  62 }
  63
  64 PP(pp_regcreset)
  65 {
  66     dVAR;
  67     /* XXXX Should store the old value to allow for tie/overload - and
  68        restore in regcomp, where marked with XXXX. */
  69     PL_reginterp_cnt = 0;
  70     TAINT_NOT;
  71     return NORMAL;
  72 }
  73
  74 PP(pp_regcomp)
  75 {
  76     dVAR;
  77     dSP;
  78     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  79     SV *tmpstr;
  80     MAGIC *mg = NULL;
  81     regexp * re;
  82
  83     /* prevent recompiling under /o and ithreads. */
  84 #if defined(USE_ITHREADS)
  85     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
  86         if (PL_op->op_flags & OPf_STACKED) {
  87             dMARK;
  88             SP = MARK;
  89         }
  90         else
  91             (void)POPs;
  92         RETURN;
  93     }
  94 #endif
  95     if (PL_op->op_flags & OPf_STACKED) {
  96         /* multiple args; concatentate them */
  97         dMARK; dORIGMARK;
  98         tmpstr = PAD_SV(ARGTARG);
  99         sv_setpvn(tmpstr, "", 0);
 100         while (++MARK <= SP) {
 101             if (PL_amagic_generation) {
 102                 SV *sv;
 103                 if ((SvAMAGIC(tmpstr) || SvAMAGIC(*MARK)) &&
 104                     (sv = amagic_call(tmpstr, *MARK, concat_amg, AMGf_assign)))
 105                 {
 106                    sv_setsv(tmpstr, sv);
 107                    continue;
 108                 }
 109             }
 110             sv_catsv(tmpstr, *MARK);
 111         }
 112         SvSETMAGIC(tmpstr);
 113         SP = ORIGMARK;
 114     }
 115     else
 116         tmpstr = POPs;
 117
 118     if (SvROK(tmpstr)) {
 119         SV * const sv = SvRV(tmpstr);
 120         if(SvMAGICAL(sv))
 121             mg = mg_find(sv, PERL_MAGIC_qr);
 122     }
 123     if (mg) {
 124         regexp * const re = reg_temp_copy((regexp *)mg->mg_obj);
 125         ReREFCNT_dec(PM_GETRE(pm));
 126         PM_SETRE(pm, re);
 127     }
 128     else {
 129         STRLEN len;
 130         const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
 131         re = PM_GETRE(pm);
 132
 133         /* Check against the last compiled regexp. */
 134         if (!re || !re->precomp || re->prelen != (I32)len ||
 135             memNE(re->precomp, t, len))
 136         {
 137             const regexp_engine *eng = re ? re->engine : NULL;
 138             U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
 139             if (re) {
 140                 ReREFCNT_dec(re);
 141                 PM_SETRE(pm, NULL);     /* crucial if regcomp aborts */
 142             } else if (PL_curcop->cop_hints_hash) {
 143                 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
 144                                        "regcomp", 7, 0, 0);
 145                 if (ptr && SvIOK(ptr) && SvIV(ptr))
 146                     eng = INT2PTR(regexp_engine*,SvIV(ptr));
 147             }
 148
 149             if (PL_op->op_flags & OPf_SPECIAL)
 150                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 151
 152             if (DO_UTF8(tmpstr))
 153                 pm_flags |= RXf_UTF8;
 154
 155                 if (eng)
 156                 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
 157                 else
 158                 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
 159
 160             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
 161                                            inside tie/overload accessors.  */
 162         }
 163     }
 164
 165     re = PM_GETRE(pm);
 166
 167 #ifndef INCOMPLETE_TAINTS
 168     if (PL_tainting) {
 169         if (PL_tainted)
 170             re->extflags |= RXf_TAINTED;
 171         else
 172             re->extflags &= ~RXf_TAINTED;
 173     }
 174 #endif
 175
 176     if (!PM_GETRE(pm)->prelen && PL_curpm)
 177         pm = PL_curpm;
 178
 179
 180 #if !defined(USE_ITHREADS)
 181     /* can't change the optree at runtime either */
 182     /* PMf_KEEP is handled differently under threads to avoid these problems */
 183     if (pm->op_pmflags & PMf_KEEP) {
 184         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 185         cLOGOP->op_first->op_next = PL_op->op_next;
 186     }
 187 #endif
 188     RETURN;
 189 }
 190
 191 PP(pp_substcont)
 192 {
 193     dVAR;
 194     dSP;
 195     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 196     register PMOP * const pm = (PMOP*) cLOGOP->op_other;
 197     register SV * const dstr = cx->sb_dstr;
 198     register char *s = cx->sb_s;
 199     register char *m = cx->sb_m;
 200     char *orig = cx->sb_orig;
 201     register REGEXP * const rx = cx->sb_rx;
 202     SV *nsv = NULL;
 203     REGEXP *old = PM_GETRE(pm);
 204     if(old != rx) {
 205         if(old)
 206             ReREFCNT_dec(old);
 207         PM_SETRE(pm,ReREFCNT_inc(rx));
 208     }
 209
 210     rxres_restore(&cx->sb_rxres, rx);
 211     RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
 212
 213     if (cx->sb_iters++) {
 214         const I32 saviters = cx->sb_iters;
 215         if (cx->sb_iters > cx->sb_maxiters)
 216             DIE(aTHX_ "Substitution loop");
 217
 218         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 219             cx->sb_rxtainted |= 2;
 220         sv_catsv(dstr, POPs);
 221         FREETMPS; /* Prevent excess tmp stack */
 222
 223         /* Are we done */
 224         if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig,
 225                                      s == m, cx->sb_targ, NULL,
 226                                      ((cx->sb_rflags & REXEC_COPY_STR)
 227                                       ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 228                                       : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 229         {
 230             SV * const targ = cx->sb_targ;
 231
 232             assert(cx->sb_strend >= s);
 233             if(cx->sb_strend > s) {
 234                  if (DO_UTF8(dstr) && !SvUTF8(targ))
 235                       sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 236                  else
 237                       sv_catpvn(dstr, s, cx->sb_strend - s);
 238             }
 239             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 240
 241 #ifdef PERL_OLD_COPY_ON_WRITE
 242             if (SvIsCOW(targ)) {
 243                 sv_force_normal_flags(targ, SV_COW_DROP_PV);
 244             } else
 245 #endif
 246             {
 247                 SvPV_free(targ);
 248             }
 249             SvPV_set(targ, SvPVX(dstr));
 250             SvCUR_set(targ, SvCUR(dstr));
 251             SvLEN_set(targ, SvLEN(dstr));
 252             if (DO_UTF8(dstr))
 253                 SvUTF8_on(targ);
 254             SvPV_set(dstr, NULL);
 255
 256             TAINT_IF(cx->sb_rxtainted & 1);
 257             PUSHs(sv_2mortal(newSViv(saviters - 1)));
 258
 259             (void)SvPOK_only_UTF8(targ);
 260             TAINT_IF(cx->sb_rxtainted);
 261             SvSETMAGIC(targ);
 262             SvTAINT(targ);
 263
 264             LEAVE_SCOPE(cx->sb_oldsave);
 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->offs[0].start + 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->offs[0].end + orig;
 285     { /* Update the pos() information. */
 286         SV * const sv = cx->sb_targ;
 287         MAGIC *mg;
 288         I32 i;
 289         SvUPGRADE(sv, SVt_PVMG);
 290         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 291 #ifdef PERL_OLD_COPY_ON_WRITE
 292             if (SvIsCOW(sv))
 293                 sv_force_normal_flags(sv, 0);
 294 #endif
 295             mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
 296                              NULL, 0);
 297         }
 298         i = m - orig;
 299         if (DO_UTF8(sv))
 300             sv_pos_b2u(sv, &i);
 301         mg->mg_len = i;
 302     }
 303     if (old != rx)
 304         (void)ReREFCNT_inc(rx);
 305     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 306     rxres_save(&cx->sb_rxres, rx);
 307     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
 308 }
 309
 310 void
 311 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 312 {
 313     UV *p = (UV*)*rsp;
 314     U32 i;
 315     PERL_UNUSED_CONTEXT;
 316
 317     if (!p || p[1] < rx->nparens) {
 318 #ifdef PERL_OLD_COPY_ON_WRITE
 319         i = 7 + rx->nparens * 2;
 320 #else
 321         i = 6 + rx->nparens * 2;
 322 #endif
 323         if (!p)
 324             Newx(p, i, UV);
 325         else
 326             Renew(p, i, UV);
 327         *rsp = (void*)p;
 328     }
 329
 330     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? rx->subbeg : NULL);
 331     RX_MATCH_COPIED_off(rx);
 332
 333 #ifdef PERL_OLD_COPY_ON_WRITE
 334     *p++ = PTR2UV(rx->saved_copy);
 335     rx->saved_copy = NULL;
 336 #endif
 337
 338     *p++ = rx->nparens;
 339
 340     *p++ = PTR2UV(rx->subbeg);
 341     *p++ = (UV)rx->sublen;
 342     for (i = 0; i <= rx->nparens; ++i) {
 343         *p++ = (UV)rx->offs[i].start;
 344         *p++ = (UV)rx->offs[i].end;
 345     }
 346 }
 347
 348 void
 349 Perl_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 350 {
 351     UV *p = (UV*)*rsp;
 352     U32 i;
 353     PERL_UNUSED_CONTEXT;
 354
 355     RX_MATCH_COPY_FREE(rx);
 356     RX_MATCH_COPIED_set(rx, *p);
 357     *p++ = 0;
 358
 359 #ifdef PERL_OLD_COPY_ON_WRITE
 360     if (rx->saved_copy)
 361         SvREFCNT_dec (rx->saved_copy);
 362     rx->saved_copy = INT2PTR(SV*,*p);
 363     *p++ = 0;
 364 #endif
 365
 366     rx->nparens = *p++;
 367
 368     rx->subbeg = INT2PTR(char*,*p++);
 369     rx->sublen = (I32)(*p++);
 370     for (i = 0; i <= rx->nparens; ++i) {
 371         rx->offs[i].start = (I32)(*p++);
 372         rx->offs[i].end = (I32)(*p++);
 373     }
 374 }
 375
 376 void
 377 Perl_rxres_free(pTHX_ void **rsp)
 378 {
 379     UV * const p = (UV*)*rsp;
 380     PERL_UNUSED_CONTEXT;
 381
 382     if (p) {
 383 #ifdef PERL_POISON
 384         void *tmp = INT2PTR(char*,*p);
 385         Safefree(tmp);
 386         if (*p)
 387             PoisonFree(*p, 1, sizeof(*p));
 388 #else
 389         Safefree(INT2PTR(char*,*p));
 390 #endif
 391 #ifdef PERL_OLD_COPY_ON_WRITE
 392         if (p[1]) {
 393             SvREFCNT_dec (INT2PTR(SV*,p[1]));
 394         }
 395 #endif
 396         Safefree(p);
 397         *rsp = NULL;
 398     }
 399 }
 400
 401 PP(pp_formline)
 402 {
 403     dVAR; dSP; dMARK; dORIGMARK;
 404     register SV * const tmpForm = *++MARK;
 405     register U32 *fpc;
 406     register char *t;
 407     const char *f;
 408     register I32 arg;
 409     register SV *sv = NULL;
 410     const char *item = NULL;
 411     I32 itemsize  = 0;
 412     I32 fieldsize = 0;
 413     I32 lines = 0;
 414     bool chopspace = (strchr(PL_chopset, ' ') != NULL);
 415     const char *chophere = NULL;
 416     char *linemark = NULL;
 417     NV value;
 418     bool gotsome = FALSE;
 419     STRLEN len;
 420     const STRLEN fudge = SvPOK(tmpForm)
 421                         ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
 422     bool item_is_utf8 = FALSE;
 423     bool targ_is_utf8 = FALSE;
 424     SV * nsv = NULL;
 425     OP * parseres = NULL;
 426     const char *fmt;
 427     bool oneline;
 428
 429     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 430         if (SvREADONLY(tmpForm)) {
 431             SvREADONLY_off(tmpForm);
 432             parseres = doparseform(tmpForm);
 433             SvREADONLY_on(tmpForm);
 434         }
 435         else
 436             parseres = doparseform(tmpForm);
 437         if (parseres)
 438             return parseres;
 439     }
 440     SvPV_force(PL_formtarget, len);
 441     if (DO_UTF8(PL_formtarget))
 442         targ_is_utf8 = TRUE;
 443     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 444     t += len;
 445     f = SvPV_const(tmpForm, len);
 446     /* need to jump to the next word */
 447     fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
 448
 449     for (;;) {
 450         DEBUG_f( {
 451             const char *name = "???";
 452             arg = -1;
 453             switch (*fpc) {
 454             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 455             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 456             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 457             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 458             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 459
 460             case FF_CHECKNL:    name = "CHECKNL";       break;
 461             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 462             case FF_SPACE:      name = "SPACE";         break;
 463             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 464             case FF_ITEM:       name = "ITEM";          break;
 465             case FF_CHOP:       name = "CHOP";          break;
 466             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 467             case FF_NEWLINE:    name = "NEWLINE";       break;
 468             case FF_MORE:       name = "MORE";          break;
 469             case FF_LINEMARK:   name = "LINEMARK";      break;
 470             case FF_END:        name = "END";           break;
 471             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 472             case FF_LINESNGL:   name = "LINESNGL";      break;
 473             }
 474             if (arg >= 0)
 475                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 476             else
 477                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 478         } );
 479         switch (*fpc++) {
 480         case FF_LINEMARK:
 481             linemark = t;
 482             lines++;
 483             gotsome = FALSE;
 484             break;
 485
 486         case FF_LITERAL:
 487             arg = *fpc++;
 488             if (targ_is_utf8 && !SvUTF8(tmpForm)) {
 489                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 490                 *t = '\0';
 491                 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
 492                 t = SvEND(PL_formtarget);
 493                 break;
 494             }
 495             if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
 496                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 497                 *t = '\0';
 498                 sv_utf8_upgrade(PL_formtarget);
 499                 SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 500                 t = SvEND(PL_formtarget);
 501                 targ_is_utf8 = TRUE;
 502             }
 503             while (arg--)
 504                 *t++ = *f++;
 505             break;
 506
 507         case FF_SKIP:
 508             f += *fpc++;
 509             break;
 510
 511         case FF_FETCH:
 512             arg = *fpc++;
 513             f += arg;
 514             fieldsize = arg;
 515
 516             if (MARK < SP)
 517                 sv = *++MARK;
 518             else {
 519                 sv = &PL_sv_no;
 520                 if (ckWARN(WARN_SYNTAX))
 521                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 522             }
 523             break;
 524
 525         case FF_CHECKNL:
 526             {
 527                 const char *send;
 528                 const char *s = item = SvPV_const(sv, len);
 529                 itemsize = len;
 530                 if (DO_UTF8(sv)) {
 531                     itemsize = sv_len_utf8(sv);
 532                     if (itemsize != (I32)len) {
 533                         I32 itembytes;
 534                         if (itemsize > fieldsize) {
 535                             itemsize = fieldsize;
 536                             itembytes = itemsize;
 537                             sv_pos_u2b(sv, &itembytes, 0);
 538                         }
 539                         else
 540                             itembytes = len;
 541                         send = chophere = s + itembytes;
 542                         while (s < send) {
 543                             if (*s & ~31)
 544                                 gotsome = TRUE;
 545                             else if (*s == '\n')
 546                                 break;
 547                             s++;
 548                         }
 549                         item_is_utf8 = TRUE;
 550                         itemsize = s - item;
 551                         sv_pos_b2u(sv, &itemsize);
 552                         break;
 553                     }
 554                 }
 555                 item_is_utf8 = FALSE;
 556                 if (itemsize > fieldsize)
 557                     itemsize = fieldsize;
 558                 send = chophere = s + itemsize;
 559                 while (s < send) {
 560                     if (*s & ~31)
 561                         gotsome = TRUE;
 562                     else if (*s == '\n')
 563                         break;
 564                     s++;
 565                 }
 566                 itemsize = s - item;
 567                 break;
 568             }
 569
 570         case FF_CHECKCHOP:
 571             {
 572                 const char *s = item = SvPV_const(sv, len);
 573                 itemsize = len;
 574                 if (DO_UTF8(sv)) {
 575                     itemsize = sv_len_utf8(sv);
 576                     if (itemsize != (I32)len) {
 577                         I32 itembytes;
 578                         if (itemsize <= fieldsize) {
 579                             const char *send = chophere = s + itemsize;
 580                             while (s < send) {
 581                                 if (*s == '\r') {
 582                                     itemsize = s - item;
 583                                     chophere = s;
 584                                     break;
 585                                 }
 586                                 if (*s++ & ~31)
 587                                     gotsome = TRUE;
 588                             }
 589                         }
 590                         else {
 591                             const char *send;
 592                             itemsize = fieldsize;
 593                             itembytes = itemsize;
 594                             sv_pos_u2b(sv, &itembytes, 0);
 595                             send = chophere = s + itembytes;
 596                             while (s < send || (s == send && isSPACE(*s))) {
 597                                 if (isSPACE(*s)) {
 598                                     if (chopspace)
 599                                         chophere = s;
 600                                     if (*s == '\r')
 601                                         break;
 602                                 }
 603                                 else {
 604                                     if (*s & ~31)
 605                                         gotsome = TRUE;
 606                                     if (strchr(PL_chopset, *s))
 607                                         chophere = s + 1;
 608                                 }
 609                                 s++;
 610                             }
 611                             itemsize = chophere - item;
 612                             sv_pos_b2u(sv, &itemsize);
 613                         }
 614                         item_is_utf8 = TRUE;
 615                         break;
 616                     }
 617                 }
 618                 item_is_utf8 = FALSE;
 619                 if (itemsize <= fieldsize) {
 620                     const char *const send = chophere = s + itemsize;
 621                     while (s < send) {
 622                         if (*s == '\r') {
 623                             itemsize = s - item;
 624                             chophere = s;
 625                             break;
 626                         }
 627                         if (*s++ & ~31)
 628                             gotsome = TRUE;
 629                     }
 630                 }
 631                 else {
 632                     const char *send;
 633                     itemsize = fieldsize;
 634                     send = chophere = s + itemsize;
 635                     while (s < send || (s == send && isSPACE(*s))) {
 636                         if (isSPACE(*s)) {
 637                             if (chopspace)
 638                                 chophere = s;
 639                             if (*s == '\r')
 640                                 break;
 641                         }
 642                         else {
 643                             if (*s & ~31)
 644                                 gotsome = TRUE;
 645                             if (strchr(PL_chopset, *s))
 646                                 chophere = s + 1;
 647                         }
 648                         s++;
 649                     }
 650                     itemsize = chophere - item;
 651                 }
 652                 break;
 653             }
 654
 655         case FF_SPACE:
 656             arg = fieldsize - itemsize;
 657             if (arg) {
 658                 fieldsize -= arg;
 659                 while (arg-- > 0)
 660                     *t++ = ' ';
 661             }
 662             break;
 663
 664         case FF_HALFSPACE:
 665             arg = fieldsize - itemsize;
 666             if (arg) {
 667                 arg /= 2;
 668                 fieldsize -= arg;
 669                 while (arg-- > 0)
 670                     *t++ = ' ';
 671             }
 672             break;
 673
 674         case FF_ITEM:
 675             {
 676                 const char *s = item;
 677                 arg = itemsize;
 678                 if (item_is_utf8) {
 679                     if (!targ_is_utf8) {
 680                         SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 681                         *t = '\0';
 682                         sv_utf8_upgrade(PL_formtarget);
 683                         SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 684                         t = SvEND(PL_formtarget);
 685                         targ_is_utf8 = TRUE;
 686                     }
 687                     while (arg--) {
 688                         if (UTF8_IS_CONTINUED(*s)) {
 689                             STRLEN skip = UTF8SKIP(s);
 690                             switch (skip) {
 691                             default:
 692                                 Move(s,t,skip,char);
 693                                 s += skip;
 694                                 t += skip;
 695                                 break;
 696                             case 7: *t++ = *s++;
 697                             case 6: *t++ = *s++;
 698                             case 5: *t++ = *s++;
 699                             case 4: *t++ = *s++;
 700                             case 3: *t++ = *s++;
 701                             case 2: *t++ = *s++;
 702                             case 1: *t++ = *s++;
 703                             }
 704                         }
 705                         else {
 706                             if ( !((*t++ = *s++) & ~31) )
 707                                 t[-1] = ' ';
 708                         }
 709                     }
 710                     break;
 711                 }
 712                 if (targ_is_utf8 && !item_is_utf8) {
 713                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 714                     *t = '\0';
 715                     sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
 716                     for (; t < SvEND(PL_formtarget); t++) {
 717 #ifdef EBCDIC
 718                         const int ch = *t;
 719                         if (iscntrl(ch))
 720 #else
 721                             if (!(*t & ~31))
 722 #endif
 723                                 *t = ' ';
 724                     }
 725                     break;
 726                 }
 727                 while (arg--) {
 728 #ifdef EBCDIC
 729                     const int ch = *t++ = *s++;
 730                     if (iscntrl(ch))
 731 #else
 732                         if ( !((*t++ = *s++) & ~31) )
 733 #endif
 734                             t[-1] = ' ';
 735                 }
 736                 break;
 737             }
 738
 739         case FF_CHOP:
 740             {
 741                 const char *s = chophere;
 742                 if (chopspace) {
 743                     while (isSPACE(*s))
 744                         s++;
 745                 }
 746                 sv_chop(sv,s);
 747                 SvSETMAGIC(sv);
 748                 break;
 749             }
 750
 751         case FF_LINESNGL:
 752             chopspace = 0;
 753             oneline = TRUE;
 754             goto ff_line;
 755         case FF_LINEGLOB:
 756             oneline = FALSE;
 757         ff_line:
 758             {
 759                 const char *s = item = SvPV_const(sv, len);
 760                 itemsize = len;
 761                 if ((item_is_utf8 = DO_UTF8(sv)))
 762                     itemsize = sv_len_utf8(sv);
 763                 if (itemsize) {
 764                     bool chopped = FALSE;
 765                     const char *const send = s + len;
 766                     gotsome = TRUE;
 767                     chophere = s + itemsize;
 768                     while (s < send) {
 769                         if (*s++ == '\n') {
 770                             if (oneline) {
 771                                 chopped = TRUE;
 772                                 chophere = s;
 773                                 break;
 774                             } else {
 775                                 if (s == send) {
 776                                     itemsize--;
 777                                     chopped = TRUE;
 778                                 } else
 779                                     lines++;
 780                             }
 781                         }
 782                     }
 783                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 784                     if (targ_is_utf8)
 785                         SvUTF8_on(PL_formtarget);
 786                     if (oneline) {
 787                         SvCUR_set(sv, chophere - item);
 788                         sv_catsv(PL_formtarget, sv);
 789                         SvCUR_set(sv, itemsize);
 790                     } else
 791                         sv_catsv(PL_formtarget, sv);
 792                     if (chopped)
 793                         SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
 794                     SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
 795                     t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 796                     if (item_is_utf8)
 797                         targ_is_utf8 = TRUE;
 798                 }
 799                 break;
 800             }
 801
 802         case FF_0DECIMAL:
 803             arg = *fpc++;
 804 #if defined(USE_LONG_DOUBLE)
 805             fmt = (const char *)
 806                 ((arg & 256) ?
 807                  "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
 808 #else
 809             fmt = (const char *)
 810                 ((arg & 256) ?
 811                  "%#0*.*f"              : "%0*.*f");
 812 #endif
 813             goto ff_dec;
 814         case FF_DECIMAL:
 815             arg = *fpc++;
 816 #if defined(USE_LONG_DOUBLE)
 817             fmt = (const char *)
 818                 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
 819 #else
 820             fmt = (const char *)
 821                 ((arg & 256) ? "%#*.*f"              : "%*.*f");
 822 #endif
 823         ff_dec:
 824             /* If the field is marked with ^ and the value is undefined,
 825                blank it out. */
 826             if ((arg & 512) && !SvOK(sv)) {
 827                 arg = fieldsize;
 828                 while (arg--)
 829                     *t++ = ' ';
 830                 break;
 831             }
 832             gotsome = TRUE;
 833             value = SvNV(sv);
 834             /* overflow evidence */
 835             if (num_overflow(value, fieldsize, arg)) {
 836                 arg = fieldsize;
 837                 while (arg--)
 838                     *t++ = '#';
 839                 break;
 840             }
 841             /* Formats aren't yet marked for locales, so assume "yes". */
 842             {
 843                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 844                 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
 845                 RESTORE_NUMERIC_STANDARD();
 846             }
 847             t += fieldsize;
 848             break;
 849
 850         case FF_NEWLINE:
 851             f++;
 852             while (t-- > linemark && *t == ' ') ;
 853             t++;
 854             *t++ = '\n';
 855             break;
 856
 857         case FF_BLANK:
 858             arg = *fpc++;
 859             if (gotsome) {
 860                 if (arg) {              /* repeat until fields exhausted? */
 861                     *t = '\0';
 862                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 863                     lines += FmLINES(PL_formtarget);
 864                     if (lines == 200) {
 865                         arg = t - linemark;
 866                         if (strnEQ(linemark, linemark - arg, arg))
 867                             DIE(aTHX_ "Runaway format");
 868                     }
 869                     if (targ_is_utf8)
 870                         SvUTF8_on(PL_formtarget);
 871                     FmLINES(PL_formtarget) = lines;
 872                     SP = ORIGMARK;
 873                     RETURNOP(cLISTOP->op_first);
 874                 }
 875             }
 876             else {
 877                 t = linemark;
 878                 lines--;
 879             }
 880             break;
 881
 882         case FF_MORE:
 883             {
 884                 const char *s = chophere;
 885                 const char *send = item + len;
 886                 if (chopspace) {
 887                     while (isSPACE(*s) && (s < send))
 888                         s++;
 889                 }
 890                 if (s < send) {
 891                     char *s1;
 892                     arg = fieldsize - itemsize;
 893                     if (arg) {
 894                         fieldsize -= arg;
 895                         while (arg-- > 0)
 896                             *t++ = ' ';
 897                     }
 898                     s1 = t - 3;
 899                     if (strnEQ(s1,"   ",3)) {
 900                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
 901                             s1--;
 902                     }
 903                     *s1++ = '.';
 904                     *s1++ = '.';
 905                     *s1++ = '.';
 906                 }
 907                 break;
 908             }
 909         case FF_END:
 910             *t = '\0';
 911             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 912             if (targ_is_utf8)
 913                 SvUTF8_on(PL_formtarget);
 914             FmLINES(PL_formtarget) += lines;
 915             SP = ORIGMARK;
 916             RETPUSHYES;
 917         }
 918     }
 919 }
 920
 921 PP(pp_grepstart)
 922 {
 923     dVAR; dSP;
 924     SV *src;
 925
 926     if (PL_stack_base + *PL_markstack_ptr == SP) {
 927         (void)POPMARK;
 928         if (GIMME_V == G_SCALAR)
 929             XPUSHs(sv_2mortal(newSViv(0)));
 930         RETURNOP(PL_op->op_next->op_next);
 931     }
 932     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
 933     pp_pushmark();                              /* push dst */
 934     pp_pushmark();                              /* push src */
 935     ENTER;                                      /* enter outer scope */
 936
 937     SAVETMPS;
 938     if (PL_op->op_private & OPpGREP_LEX)
 939         SAVESPTR(PAD_SVl(PL_op->op_targ));
 940     else
 941         SAVE_DEFSV;
 942     ENTER;                                      /* enter inner scope */
 943     SAVEVPTR(PL_curpm);
 944
 945     src = PL_stack_base[*PL_markstack_ptr];
 946     SvTEMP_off(src);
 947     if (PL_op->op_private & OPpGREP_LEX)
 948         PAD_SVl(PL_op->op_targ) = src;
 949     else
 950         DEFSV = src;
 951
 952     PUTBACK;
 953     if (PL_op->op_type == OP_MAPSTART)
 954         pp_pushmark();                  /* push top */
 955     return ((LOGOP*)PL_op->op_next)->op_other;
 956 }
 957
 958 PP(pp_mapwhile)
 959 {
 960     dVAR; dSP;
 961     const I32 gimme = GIMME_V;
 962     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
 963     I32 count;
 964     I32 shift;
 965     SV** src;
 966     SV** dst;
 967
 968     /* first, move source pointer to the next item in the source list */
 969     ++PL_markstack_ptr[-1];
 970
 971     /* if there are new items, push them into the destination list */
 972     if (items && gimme != G_VOID) {
 973         /* might need to make room back there first */
 974         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
 975             /* XXX this implementation is very pessimal because the stack
 976              * is repeatedly extended for every set of items.  Is possible
 977              * to do this without any stack extension or copying at all
 978              * by maintaining a separate list over which the map iterates
 979              * (like foreach does). --gsar */
 980
 981             /* everything in the stack after the destination list moves
 982              * towards the end the stack by the amount of room needed */
 983             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
 984
 985             /* items to shift up (accounting for the moved source pointer) */
 986             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
 987
 988             /* This optimization is by Ben Tilly and it does
 989              * things differently from what Sarathy (gsar)
 990              * is describing.  The downside of this optimization is
 991              * that leaves "holes" (uninitialized and hopefully unused areas)
 992              * to the Perl stack, but on the other hand this
 993              * shouldn't be a problem.  If Sarathy's idea gets
 994              * implemented, this optimization should become
 995              * irrelevant.  --jhi */
 996             if (shift < count)
 997                 shift = count; /* Avoid shifting too often --Ben Tilly */
 998
 999             EXTEND(SP,shift);
1000             src = SP;
1001             dst = (SP += shift);
1002             PL_markstack_ptr[-1] += shift;
1003             *PL_markstack_ptr += shift;
1004             while (count--)
1005                 *dst-- = *src--;
1006         }
1007         /* copy the new items down to the destination list */
1008         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1009         if (gimme == G_ARRAY) {
1010             while (items-- > 0)
1011                 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1012         }
1013         else {
1014             /* scalar context: we don't care about which values map returns
1015              * (we use undef here). And so we certainly don't want to do mortal
1016              * copies of meaningless values. */
1017             while (items-- > 0) {
1018                 (void)POPs;
1019                 *dst-- = &PL_sv_undef;
1020             }
1021         }
1022     }
1023     LEAVE;                                      /* exit inner scope */
1024
1025     /* All done yet? */
1026     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1027
1028         (void)POPMARK;                          /* pop top */
1029         LEAVE;                                  /* exit outer scope */
1030         (void)POPMARK;                          /* pop src */
1031         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1032         (void)POPMARK;                          /* pop dst */
1033         SP = PL_stack_base + POPMARK;           /* pop original mark */
1034         if (gimme == G_SCALAR) {
1035             if (PL_op->op_private & OPpGREP_LEX) {
1036                 SV* sv = sv_newmortal();
1037                 sv_setiv(sv, items);
1038                 PUSHs(sv);
1039             }
1040             else {
1041                 dTARGET;
1042                 XPUSHi(items);
1043             }
1044         }
1045         else if (gimme == G_ARRAY)
1046             SP += items;
1047         RETURN;
1048     }
1049     else {
1050         SV *src;
1051
1052         ENTER;                                  /* enter inner scope */
1053         SAVEVPTR(PL_curpm);
1054
1055         /* set $_ to the new source item */
1056         src = PL_stack_base[PL_markstack_ptr[-1]];
1057         SvTEMP_off(src);
1058         if (PL_op->op_private & OPpGREP_LEX)
1059             PAD_SVl(PL_op->op_targ) = src;
1060         else
1061             DEFSV = src;
1062
1063         RETURNOP(cLOGOP->op_other);
1064     }
1065 }
1066
1067 /* Range stuff. */
1068
1069 PP(pp_range)
1070 {
1071     dVAR;
1072     if (GIMME == G_ARRAY)
1073         return NORMAL;
1074     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1075         return cLOGOP->op_other;
1076     else
1077         return NORMAL;
1078 }
1079
1080 PP(pp_flip)
1081 {
1082     dVAR;
1083     dSP;
1084
1085     if (GIMME == G_ARRAY) {
1086         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1087     }
1088     else {
1089         dTOPss;
1090         SV * const targ = PAD_SV(PL_op->op_targ);
1091         int flip = 0;
1092
1093         if (PL_op->op_private & OPpFLIP_LINENUM) {
1094             if (GvIO(PL_last_in_gv)) {
1095                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1096             }
1097             else {
1098                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1099                 if (gv && GvSV(gv))
1100                     flip = SvIV(sv) == SvIV(GvSV(gv));
1101             }
1102         } else {
1103             flip = SvTRUE(sv);
1104         }
1105         if (flip) {
1106             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1107             if (PL_op->op_flags & OPf_SPECIAL) {
1108                 sv_setiv(targ, 1);
1109                 SETs(targ);
1110                 RETURN;
1111             }
1112             else {
1113                 sv_setiv(targ, 0);
1114                 SP--;
1115                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1116             }
1117         }
1118         sv_setpvn(TARG, "", 0);
1119         SETs(targ);
1120         RETURN;
1121     }
1122 }
1123
1124 /* This code tries to decide if "$left .. $right" should use the
1125    magical string increment, or if the range is numeric (we make
1126    an exception for .."0" [#18165]). AMS 20021031. */
1127
1128 #define RANGE_IS_NUMERIC(left,right) ( \
1129         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1130         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1131         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1132           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1133          && (!SvOK(right) || looks_like_number(right))))
1134
1135 PP(pp_flop)
1136 {
1137     dVAR; dSP;
1138
1139     if (GIMME == G_ARRAY) {
1140         dPOPPOPssrl;
1141
1142         SvGETMAGIC(left);
1143         SvGETMAGIC(right);
1144
1145         if (RANGE_IS_NUMERIC(left,right)) {
1146             register IV i, j;
1147             IV max;
1148             if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1149                 (SvOK(right) && SvNV(right) > IV_MAX))
1150                 DIE(aTHX_ "Range iterator outside integer range");
1151             i = SvIV(left);
1152             max = SvIV(right);
1153             if (max >= i) {
1154                 j = max - i + 1;
1155                 EXTEND_MORTAL(j);
1156                 EXTEND(SP, j);
1157             }
1158             else
1159                 j = 0;
1160             while (j--) {
1161                 SV * const sv = sv_2mortal(newSViv(i++));
1162                 PUSHs(sv);
1163             }
1164         }
1165         else {
1166             SV * const final = sv_mortalcopy(right);
1167             STRLEN len;
1168             const char * const tmps = SvPV_const(final, len);
1169
1170             SV *sv = sv_mortalcopy(left);
1171             SvPV_force_nolen(sv);
1172             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1173                 XPUSHs(sv);
1174                 if (strEQ(SvPVX_const(sv),tmps))
1175                     break;
1176                 sv = sv_2mortal(newSVsv(sv));
1177                 sv_inc(sv);
1178             }
1179         }
1180     }
1181     else {
1182         dTOPss;
1183         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1184         int flop = 0;
1185         sv_inc(targ);
1186
1187         if (PL_op->op_private & OPpFLIP_LINENUM) {
1188             if (GvIO(PL_last_in_gv)) {
1189                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1190             }
1191             else {
1192                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1193                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1194             }
1195         }
1196         else {
1197             flop = SvTRUE(sv);
1198         }
1199
1200         if (flop) {
1201             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1202             sv_catpvs(targ, "E0");
1203         }
1204         SETs(targ);
1205     }
1206
1207     RETURN;
1208 }
1209
1210 /* Control. */
1211
1212 static const char * const context_name[] = {
1213     "pseudo-block",
1214     "subroutine",
1215     "eval",
1216     "loop",
1217     "substitution",
1218     "block",
1219     "format",
1220     "given",
1221     "when"
1222 };
1223
1224 STATIC I32
1225 S_dopoptolabel(pTHX_ const char *label)
1226 {
1227     dVAR;
1228     register I32 i;
1229
1230     for (i = cxstack_ix; i >= 0; i--) {
1231         register const PERL_CONTEXT * const cx = &cxstack[i];
1232         switch (CxTYPE(cx)) {
1233         case CXt_SUBST:
1234         case CXt_SUB:
1235         case CXt_FORMAT:
1236         case CXt_EVAL:
1237         case CXt_NULL:
1238         case CXt_GIVEN:
1239         case CXt_WHEN:
1240             if (ckWARN(WARN_EXITING))
1241                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1242                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1243             if (CxTYPE(cx) == CXt_NULL)
1244                 return -1;
1245             break;
1246         case CXt_LOOP:
1247             if ( !cx->blk_loop.label || strNE(label, cx->blk_loop.label) ) {
1248                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1249                         (long)i, cx->blk_loop.label));
1250                 continue;
1251             }
1252             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1253             return i;
1254         }
1255     }
1256     return i;
1257 }
1258
1259
1260
1261 I32
1262 Perl_dowantarray(pTHX)
1263 {
1264     dVAR;
1265     const I32 gimme = block_gimme();
1266     return (gimme == G_VOID) ? G_SCALAR : gimme;
1267 }
1268
1269 I32
1270 Perl_block_gimme(pTHX)
1271 {
1272     dVAR;
1273     const I32 cxix = dopoptosub(cxstack_ix);
1274     if (cxix < 0)
1275         return G_VOID;
1276
1277     switch (cxstack[cxix].blk_gimme) {
1278     case G_VOID:
1279         return G_VOID;
1280     case G_SCALAR:
1281         return G_SCALAR;
1282     case G_ARRAY:
1283         return G_ARRAY;
1284     default:
1285         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1286         /* NOTREACHED */
1287         return 0;
1288     }
1289 }
1290
1291 I32
1292 Perl_is_lvalue_sub(pTHX)
1293 {
1294     dVAR;
1295     const I32 cxix = dopoptosub(cxstack_ix);
1296     assert(cxix >= 0);  /* We should only be called from inside subs */
1297
1298     if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
1299         return cxstack[cxix].blk_sub.lval;
1300     else
1301         return 0;
1302 }
1303
1304 STATIC I32
1305 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1306 {
1307     dVAR;
1308     I32 i;
1309     for (i = startingblock; i >= 0; i--) {
1310         register const PERL_CONTEXT * const cx = &cxstk[i];
1311         switch (CxTYPE(cx)) {
1312         default:
1313             continue;
1314         case CXt_EVAL:
1315         case CXt_SUB:
1316         case CXt_FORMAT:
1317             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1318             return i;
1319         }
1320     }
1321     return i;
1322 }
1323
1324 STATIC I32
1325 S_dopoptoeval(pTHX_ I32 startingblock)
1326 {
1327     dVAR;
1328     I32 i;
1329     for (i = startingblock; i >= 0; i--) {
1330         register const PERL_CONTEXT *cx = &cxstack[i];
1331         switch (CxTYPE(cx)) {
1332         default:
1333             continue;
1334         case CXt_EVAL:
1335             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1336             return i;
1337         }
1338     }
1339     return i;
1340 }
1341
1342 STATIC I32
1343 S_dopoptoloop(pTHX_ I32 startingblock)
1344 {
1345     dVAR;
1346     I32 i;
1347     for (i = startingblock; i >= 0; i--) {
1348         register const PERL_CONTEXT * const cx = &cxstack[i];
1349         switch (CxTYPE(cx)) {
1350         case CXt_SUBST:
1351         case CXt_SUB:
1352         case CXt_FORMAT:
1353         case CXt_EVAL:
1354         case CXt_NULL:
1355             if (ckWARN(WARN_EXITING))
1356                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1357                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1358             if ((CxTYPE(cx)) == CXt_NULL)
1359                 return -1;
1360             break;
1361         case CXt_LOOP:
1362             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1363             return i;
1364         }
1365     }
1366     return i;
1367 }
1368
1369 STATIC I32
1370 S_dopoptogiven(pTHX_ I32 startingblock)
1371 {
1372     dVAR;
1373     I32 i;
1374     for (i = startingblock; i >= 0; i--) {
1375         register const PERL_CONTEXT *cx = &cxstack[i];
1376         switch (CxTYPE(cx)) {
1377         default:
1378             continue;
1379         case CXt_GIVEN:
1380             DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1381             return i;
1382         case CXt_LOOP:
1383             if (CxFOREACHDEF(cx)) {
1384                 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1385                 return i;
1386             }
1387         }
1388     }
1389     return i;
1390 }
1391
1392 STATIC I32
1393 S_dopoptowhen(pTHX_ I32 startingblock)
1394 {
1395     dVAR;
1396     I32 i;
1397     for (i = startingblock; i >= 0; i--) {
1398         register const PERL_CONTEXT *cx = &cxstack[i];
1399         switch (CxTYPE(cx)) {
1400         default:
1401             continue;
1402         case CXt_WHEN:
1403             DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1404             return i;
1405         }
1406     }
1407     return i;
1408 }
1409
1410 void
1411 Perl_dounwind(pTHX_ I32 cxix)
1412 {
1413     dVAR;
1414     I32 optype;
1415
1416     while (cxstack_ix > cxix) {
1417         SV *sv;
1418         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1419         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1420                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1421         /* Note: we don't need to restore the base context info till the end. */
1422         switch (CxTYPE(cx)) {
1423         case CXt_SUBST:
1424             POPSUBST(cx);
1425             continue;  /* not break */
1426         case CXt_SUB:
1427             POPSUB(cx,sv);
1428             LEAVESUB(sv);
1429             break;
1430         case CXt_EVAL:
1431             POPEVAL(cx);
1432             break;
1433         case CXt_LOOP:
1434             POPLOOP(cx);
1435             break;
1436         case CXt_NULL:
1437             break;
1438         case CXt_FORMAT:
1439             POPFORMAT(cx);
1440             break;
1441         }
1442         cxstack_ix--;
1443     }
1444     PERL_UNUSED_VAR(optype);
1445 }
1446
1447 void
1448 Perl_qerror(pTHX_ SV *err)
1449 {
1450     dVAR;
1451     if (PL_in_eval)
1452         sv_catsv(ERRSV, err);
1453     else if (PL_errors)
1454         sv_catsv(PL_errors, err);
1455     else
1456         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1457     if (PL_parser)
1458         ++PL_parser->error_count;
1459 }
1460
1461 OP *
1462 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1463 {
1464     dVAR;
1465
1466     if (PL_in_eval) {
1467         I32 cxix;
1468         I32 gimme;
1469
1470         if (message) {
1471             if (PL_in_eval & EVAL_KEEPERR) {
1472                 static const char prefix[] = "\t(in cleanup) ";
1473                 SV * const err = ERRSV;
1474                 const char *e = NULL;
1475                 if (!SvPOK(err))
1476                     sv_setpvn(err,"",0);
1477                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1478                     STRLEN len;
1479                     e = SvPV_const(err, len);
1480                     e += len - msglen;
1481                     if (*e != *message || strNE(e,message))
1482                         e = NULL;
1483                 }
1484                 if (!e) {
1485                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1486                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1487                     sv_catpvn(err, message, msglen);
1488                     if (ckWARN(WARN_MISC)) {
1489                         const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1490                         Perl_warner(aTHX_ packWARN(WARN_MISC), SvPVX_const(err)+start);
1491                     }
1492                 }
1493             }
1494             else {
1495                 sv_setpvn(ERRSV, message, msglen);
1496             }
1497         }
1498
1499         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1500                && PL_curstackinfo->si_prev)
1501         {
1502             dounwind(-1);
1503             POPSTACK;
1504         }
1505
1506         if (cxix >= 0) {
1507             I32 optype;
1508             register PERL_CONTEXT *cx;
1509             SV **newsp;
1510
1511             if (cxix < cxstack_ix)
1512                 dounwind(cxix);
1513
1514             POPBLOCK(cx,PL_curpm);
1515             if (CxTYPE(cx) != CXt_EVAL) {
1516                 if (!message)
1517                     message = SvPVx_const(ERRSV, msglen);
1518                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1519                 PerlIO_write(Perl_error_log, message, msglen);
1520                 my_exit(1);
1521             }
1522             POPEVAL(cx);
1523
1524             if (gimme == G_SCALAR)
1525                 *++newsp = &PL_sv_undef;
1526             PL_stack_sp = newsp;
1527
1528             LEAVE;
1529
1530             /* LEAVE could clobber PL_curcop (see save_re_context())
1531              * XXX it might be better to find a way to avoid messing with
1532              * PL_curcop in save_re_context() instead, but this is a more
1533              * minimal fix --GSAR */
1534             PL_curcop = cx->blk_oldcop;
1535
1536             if (optype == OP_REQUIRE) {
1537                 const char* const msg = SvPVx_nolen_const(ERRSV);
1538                 SV * const nsv = cx->blk_eval.old_namesv;
1539                 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1540                                &PL_sv_undef, 0);
1541                 DIE(aTHX_ "%sCompilation failed in require",
1542                     *msg ? msg : "Unknown error\n");
1543             }
1544             assert(CxTYPE(cx) == CXt_EVAL);
1545             return cx->blk_eval.retop;
1546         }
1547     }
1548     if (!message)
1549         message = SvPVx_const(ERRSV, msglen);
1550
1551     write_to_stderr(message, msglen);
1552     my_failure_exit();
1553     /* NOTREACHED */
1554     return 0;
1555 }
1556
1557 PP(pp_xor)
1558 {
1559     dVAR; dSP; dPOPTOPssrl;
1560     if (SvTRUE(left) != SvTRUE(right))
1561         RETSETYES;
1562     else
1563         RETSETNO;
1564 }
1565
1566 PP(pp_caller)
1567 {
1568     dVAR;
1569     dSP;
1570     register I32 cxix = dopoptosub(cxstack_ix);
1571     register const PERL_CONTEXT *cx;
1572     register const PERL_CONTEXT *ccstack = cxstack;
1573     const PERL_SI *top_si = PL_curstackinfo;
1574     I32 gimme;
1575     const char *stashname;
1576     I32 count = 0;
1577
1578     if (MAXARG)
1579         count = POPi;
1580
1581     for (;;) {
1582         /* we may be in a higher stacklevel, so dig down deeper */
1583         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1584             top_si = top_si->si_prev;
1585             ccstack = top_si->si_cxstack;
1586             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1587         }
1588         if (cxix < 0) {
1589             if (GIMME != G_ARRAY) {
1590                 EXTEND(SP, 1);
1591                 RETPUSHUNDEF;
1592             }
1593             RETURN;
1594         }
1595         /* caller() should not report the automatic calls to &DB::sub */
1596         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1597                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1598             count++;
1599         if (!count--)
1600             break;
1601         cxix = dopoptosub_at(ccstack, cxix - 1);
1602     }
1603
1604     cx = &ccstack[cxix];
1605     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1606         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1607         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1608            field below is defined for any cx. */
1609         /* caller() should not report the automatic calls to &DB::sub */
1610         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1611             cx = &ccstack[dbcxix];
1612     }
1613
1614     stashname = CopSTASHPV(cx->blk_oldcop);
1615     if (GIMME != G_ARRAY) {
1616         EXTEND(SP, 1);
1617         if (!stashname)
1618             PUSHs(&PL_sv_undef);
1619         else {
1620             dTARGET;
1621             sv_setpv(TARG, stashname);
1622             PUSHs(TARG);
1623         }
1624         RETURN;
1625     }
1626
1627     EXTEND(SP, 11);
1628
1629     if (!stashname)
1630         PUSHs(&PL_sv_undef);
1631     else
1632         PUSHs(sv_2mortal(newSVpv(stashname, 0)));
1633     PUSHs(sv_2mortal(newSVpv(OutCopFILE(cx->blk_oldcop), 0)));
1634     PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop))));
1635     if (!MAXARG)
1636         RETURN;
1637     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1638         GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1639         /* So is ccstack[dbcxix]. */
1640         if (isGV(cvgv)) {
1641             SV * const sv = newSV(0);
1642             gv_efullname3(sv, cvgv, NULL);
1643             PUSHs(sv_2mortal(sv));
1644             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1645         }
1646         else {
1647             PUSHs(sv_2mortal(newSVpvs("(unknown)")));
1648             PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs)));
1649         }
1650     }
1651     else {
1652         PUSHs(sv_2mortal(newSVpvs("(eval)")));
1653         PUSHs(sv_2mortal(newSViv(0)));
1654     }
1655     gimme = (I32)cx->blk_gimme;
1656     if (gimme == G_VOID)
1657         PUSHs(&PL_sv_undef);
1658     else
1659         PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
1660     if (CxTYPE(cx) == CXt_EVAL) {
1661         /* eval STRING */
1662         if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
1663             PUSHs(cx->blk_eval.cur_text);
1664             PUSHs(&PL_sv_no);
1665         }
1666         /* require */
1667         else if (cx->blk_eval.old_namesv) {
1668             PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
1669             PUSHs(&PL_sv_yes);
1670         }
1671         /* eval BLOCK (try blocks have old_namesv == 0) */
1672         else {
1673             PUSHs(&PL_sv_undef);
1674             PUSHs(&PL_sv_undef);
1675         }
1676     }
1677     else {
1678         PUSHs(&PL_sv_undef);
1679         PUSHs(&PL_sv_undef);
1680     }
1681     if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs
1682         && CopSTASH_eq(PL_curcop, PL_debstash))
1683     {
1684         AV * const ary = cx->blk_sub.argarray;
1685         const int off = AvARRAY(ary) - AvALLOC(ary);
1686
1687         if (!PL_dbargs) {
1688             GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1689             PL_dbargs = GvAV(gv_AVadd(tmpgv));
1690             GvMULTI_on(tmpgv);
1691             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1692         }
1693
1694         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1695             av_extend(PL_dbargs, AvFILLp(ary) + off);
1696         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1697         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1698     }
1699     /* XXX only hints propagated via op_private are currently
1700      * visible (others are not easily accessible, since they
1701      * use the global PL_hints) */
1702     PUSHs(sv_2mortal(newSViv(CopHINTS_get(cx->blk_oldcop))));
1703     {
1704         SV * mask ;
1705         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1706
1707         if  (old_warnings == pWARN_NONE ||
1708                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1709             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1710         else if (old_warnings == pWARN_ALL ||
1711                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1712             /* Get the bit mask for $warnings::Bits{all}, because
1713              * it could have been extended by warnings::register */
1714             SV **bits_all;
1715             HV * const bits = get_hv("warnings::Bits", FALSE);
1716             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1717                 mask = newSVsv(*bits_all);
1718             }
1719             else {
1720                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1721             }
1722         }
1723         else
1724             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1725         PUSHs(sv_2mortal(mask));
1726     }
1727
1728     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1729           sv_2mortal(newRV_noinc(
1730             (SV*)Perl_refcounted_he_chain_2hv(aTHX_
1731                                               cx->blk_oldcop->cop_hints_hash)))
1732           : &PL_sv_undef);
1733     RETURN;
1734 }
1735
1736 PP(pp_reset)
1737 {
1738     dVAR;
1739     dSP;
1740     const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1741     sv_reset(tmps, CopSTASH(PL_curcop));
1742     PUSHs(&PL_sv_yes);
1743     RETURN;
1744 }
1745
1746 /* like pp_nextstate, but used instead when the debugger is active */
1747
1748 PP(pp_dbstate)
1749 {
1750     dVAR;
1751     PL_curcop = (COP*)PL_op;
1752     TAINT_NOT;          /* Each statement is presumed innocent */
1753     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1754     FREETMPS;
1755
1756     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1757             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1758     {
1759         dSP;
1760         register PERL_CONTEXT *cx;
1761         const I32 gimme = G_ARRAY;
1762         U8 hasargs;
1763         GV * const gv = PL_DBgv;
1764         register CV * const cv = GvCV(gv);
1765
1766         if (!cv)
1767             DIE(aTHX_ "No DB::DB routine defined");
1768
1769         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1770             /* don't do recursive DB::DB call */
1771             return NORMAL;
1772
1773         ENTER;
1774         SAVETMPS;
1775
1776         SAVEI32(PL_debug);
1777         SAVESTACK_POS();
1778         PL_debug = 0;
1779         hasargs = 0;
1780         SPAGAIN;
1781
1782         if (CvISXSUB(cv)) {
1783             CvDEPTH(cv)++;
1784             PUSHMARK(SP);
1785             (void)(*CvXSUB(cv))(aTHX_ cv);
1786             CvDEPTH(cv)--;
1787             FREETMPS;
1788             LEAVE;
1789             return NORMAL;
1790         }
1791         else {
1792             PUSHBLOCK(cx, CXt_SUB, SP);
1793             PUSHSUB_DB(cx);
1794             cx->blk_sub.retop = PL_op->op_next;
1795             CvDEPTH(cv)++;
1796             SAVECOMPPAD();
1797             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1798             RETURNOP(CvSTART(cv));
1799         }
1800     }
1801     else
1802         return NORMAL;
1803 }
1804
1805 PP(pp_enteriter)
1806 {
1807     dVAR; dSP; dMARK;
1808     register PERL_CONTEXT *cx;
1809     const I32 gimme = GIMME_V;
1810     SV **svp;
1811     U16 cxtype = CXt_LOOP | CXp_FOREACH;
1812 #ifdef USE_ITHREADS
1813     void *iterdata;
1814 #endif
1815
1816     ENTER;
1817     SAVETMPS;
1818
1819     if (PL_op->op_targ) {
1820         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1821             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1822             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1823                     SVs_PADSTALE, SVs_PADSTALE);
1824         }
1825 #ifndef USE_ITHREADS
1826         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1827         SAVESPTR(*svp);
1828 #else
1829         SAVEPADSV(PL_op->op_targ);
1830         iterdata = INT2PTR(void*, PL_op->op_targ);
1831         cxtype |= CXp_PADVAR;
1832 #endif
1833     }
1834     else {
1835         GV * const gv = (GV*)POPs;
1836         svp = &GvSV(gv);                        /* symbol table variable */
1837         SAVEGENERICSV(*svp);
1838         *svp = newSV(0);
1839 #ifdef USE_ITHREADS
1840         iterdata = (void*)gv;
1841 #endif
1842     }
1843
1844     if (PL_op->op_private & OPpITER_DEF)
1845         cxtype |= CXp_FOR_DEF;
1846
1847     ENTER;
1848
1849     PUSHBLOCK(cx, cxtype, SP);
1850 #ifdef USE_ITHREADS
1851     PUSHLOOP(cx, iterdata, MARK);
1852 #else
1853     PUSHLOOP(cx, svp, MARK);
1854 #endif
1855     if (PL_op->op_flags & OPf_STACKED) {
1856         cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs);
1857         if (SvTYPE(cx->blk_loop.iterary) != SVt_PVAV) {
1858             dPOPss;
1859             SV * const right = (SV*)cx->blk_loop.iterary;
1860             SvGETMAGIC(sv);
1861             SvGETMAGIC(right);
1862             if (RANGE_IS_NUMERIC(sv,right)) {
1863                 if ((SvOK(sv) && SvNV(sv) < IV_MIN) ||
1864                     (SvOK(right) && SvNV(right) >= IV_MAX))
1865                     DIE(aTHX_ "Range iterator outside integer range");
1866                 cx->blk_loop.iterix = SvIV(sv);
1867                 cx->blk_loop.itermax = SvIV(right);
1868 #ifdef DEBUGGING
1869                 /* for correct -Dstv display */
1870                 cx->blk_oldsp = sp - PL_stack_base;
1871 #endif
1872             }
1873             else {
1874                 cx->blk_loop.iterlval = newSVsv(sv);
1875                 (void) SvPV_force_nolen(cx->blk_loop.iterlval);
1876                 (void) SvPV_nolen_const(right);
1877             }
1878         }
1879         else if (PL_op->op_private & OPpITER_REVERSED) {
1880             cx->blk_loop.itermax = 0;
1881             cx->blk_loop.iterix = AvFILL(cx->blk_loop.iterary) + 1;
1882
1883         }
1884     }
1885     else {
1886         cx->blk_loop.iterary = PL_curstack;
1887         AvFILLp(PL_curstack) = SP - PL_stack_base;
1888         if (PL_op->op_private & OPpITER_REVERSED) {
1889             cx->blk_loop.itermax = MARK - PL_stack_base + 1;
1890             cx->blk_loop.iterix = cx->blk_oldsp + 1;
1891         }
1892         else {
1893             cx->blk_loop.iterix = MARK - PL_stack_base;
1894         }
1895     }
1896
1897     RETURN;
1898 }
1899
1900 PP(pp_enterloop)
1901 {
1902     dVAR; dSP;
1903     register PERL_CONTEXT *cx;
1904     const I32 gimme = GIMME_V;
1905
1906     ENTER;
1907     SAVETMPS;
1908     ENTER;
1909
1910     PUSHBLOCK(cx, CXt_LOOP, SP);
1911     PUSHLOOP(cx, 0, SP);
1912
1913     RETURN;
1914 }
1915
1916 PP(pp_leaveloop)
1917 {
1918     dVAR; dSP;
1919     register PERL_CONTEXT *cx;
1920     I32 gimme;
1921     SV **newsp;
1922     PMOP *newpm;
1923     SV **mark;
1924
1925     POPBLOCK(cx,newpm);
1926     assert(CxTYPE(cx) == CXt_LOOP);
1927     mark = newsp;
1928     newsp = PL_stack_base + cx->blk_loop.resetsp;
1929
1930     TAINT_NOT;
1931     if (gimme == G_VOID)
1932         NOOP;
1933     else if (gimme == G_SCALAR) {
1934         if (mark < SP)
1935             *++newsp = sv_mortalcopy(*SP);
1936         else
1937             *++newsp = &PL_sv_undef;
1938     }
1939     else {
1940         while (mark < SP) {
1941             *++newsp = sv_mortalcopy(*++mark);
1942             TAINT_NOT;          /* Each item is independent */
1943         }
1944     }
1945     SP = newsp;
1946     PUTBACK;
1947
1948     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
1949     PL_curpm = newpm;   /* ... and pop $1 et al */
1950
1951     LEAVE;
1952     LEAVE;
1953
1954     return NORMAL;
1955 }
1956
1957 PP(pp_return)
1958 {
1959     dVAR; dSP; dMARK;
1960     register PERL_CONTEXT *cx;
1961     bool popsub2 = FALSE;
1962     bool clear_errsv = FALSE;
1963     I32 gimme;
1964     SV **newsp;
1965     PMOP *newpm;
1966     I32 optype = 0;
1967     SV *sv;
1968     OP *retop;
1969
1970     const I32 cxix = dopoptosub(cxstack_ix);
1971
1972     if (cxix < 0) {
1973         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
1974                                      * sort block, which is a CXt_NULL
1975                                      * not a CXt_SUB */
1976             dounwind(0);
1977             PL_stack_base[1] = *PL_stack_sp;
1978             PL_stack_sp = PL_stack_base + 1;
1979             return 0;
1980         }
1981         else
1982             DIE(aTHX_ "Can't return outside a subroutine");
1983     }
1984     if (cxix < cxstack_ix)
1985         dounwind(cxix);
1986
1987     if (CxMULTICALL(&cxstack[cxix])) {
1988         gimme = cxstack[cxix].blk_gimme;
1989         if (gimme == G_VOID)
1990             PL_stack_sp = PL_stack_base;
1991         else if (gimme == G_SCALAR) {
1992             PL_stack_base[1] = *PL_stack_sp;
1993             PL_stack_sp = PL_stack_base + 1;
1994         }
1995         return 0;
1996     }
1997
1998     POPBLOCK(cx,newpm);
1999     switch (CxTYPE(cx)) {
2000     case CXt_SUB:
2001         popsub2 = TRUE;
2002         retop = cx->blk_sub.retop;
2003         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2004         break;
2005     case CXt_EVAL:
2006         if (!(PL_in_eval & EVAL_KEEPERR))
2007             clear_errsv = TRUE;
2008         POPEVAL(cx);
2009         retop = cx->blk_eval.retop;
2010         if (CxTRYBLOCK(cx))
2011             break;
2012         lex_end();
2013         if (optype == OP_REQUIRE &&
2014             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2015         {
2016             /* Unassume the success we assumed earlier. */
2017             SV * const nsv = cx->blk_eval.old_namesv;
2018             (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2019             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2020         }
2021         break;
2022     case CXt_FORMAT:
2023         POPFORMAT(cx);
2024         retop = cx->blk_sub.retop;
2025         break;
2026     default:
2027         DIE(aTHX_ "panic: return");
2028     }
2029
2030     TAINT_NOT;
2031     if (gimme == G_SCALAR) {
2032         if (MARK < SP) {
2033             if (popsub2) {
2034                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2035                     if (SvTEMP(TOPs)) {
2036                         *++newsp = SvREFCNT_inc(*SP);
2037                         FREETMPS;
2038                         sv_2mortal(*newsp);
2039                     }
2040                     else {
2041                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2042                         FREETMPS;
2043                         *++newsp = sv_mortalcopy(sv);
2044                         SvREFCNT_dec(sv);
2045                     }
2046                 }
2047                 else
2048                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2049             }
2050             else
2051                 *++newsp = sv_mortalcopy(*SP);
2052         }
2053         else
2054             *++newsp = &PL_sv_undef;
2055     }
2056     else if (gimme == G_ARRAY) {
2057         while (++MARK <= SP) {
2058             *++newsp = (popsub2 && SvTEMP(*MARK))
2059                         ? *MARK : sv_mortalcopy(*MARK);
2060             TAINT_NOT;          /* Each item is independent */
2061         }
2062     }
2063     PL_stack_sp = newsp;
2064
2065     LEAVE;
2066     /* Stack values are safe: */
2067     if (popsub2) {
2068         cxstack_ix--;
2069         POPSUB(cx,sv);  /* release CV and @_ ... */
2070     }
2071     else
2072         sv = NULL;
2073     PL_curpm = newpm;   /* ... and pop $1 et al */
2074
2075     LEAVESUB(sv);
2076     if (clear_errsv)
2077         sv_setpvn(ERRSV,"",0);
2078     return retop;
2079 }
2080
2081 PP(pp_last)
2082 {
2083     dVAR; dSP;
2084     I32 cxix;
2085     register PERL_CONTEXT *cx;
2086     I32 pop2 = 0;
2087     I32 gimme;
2088     I32 optype;
2089     OP *nextop;
2090     SV **newsp;
2091     PMOP *newpm;
2092     SV **mark;
2093     SV *sv = NULL;
2094
2095
2096     if (PL_op->op_flags & OPf_SPECIAL) {
2097         cxix = dopoptoloop(cxstack_ix);
2098         if (cxix < 0)
2099             DIE(aTHX_ "Can't \"last\" outside a loop block");
2100     }
2101     else {
2102         cxix = dopoptolabel(cPVOP->op_pv);
2103         if (cxix < 0)
2104             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2105     }
2106     if (cxix < cxstack_ix)
2107         dounwind(cxix);
2108
2109     POPBLOCK(cx,newpm);
2110     cxstack_ix++; /* temporarily protect top context */
2111     mark = newsp;
2112     switch (CxTYPE(cx)) {
2113     case CXt_LOOP:
2114         pop2 = CXt_LOOP;
2115         newsp = PL_stack_base + cx->blk_loop.resetsp;
2116         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2117         break;
2118     case CXt_SUB:
2119         pop2 = CXt_SUB;
2120         nextop = cx->blk_sub.retop;
2121         break;
2122     case CXt_EVAL:
2123         POPEVAL(cx);
2124         nextop = cx->blk_eval.retop;
2125         break;
2126     case CXt_FORMAT:
2127         POPFORMAT(cx);
2128         nextop = cx->blk_sub.retop;
2129         break;
2130     default:
2131         DIE(aTHX_ "panic: last");
2132     }
2133
2134     TAINT_NOT;
2135     if (gimme == G_SCALAR) {
2136         if (MARK < SP)
2137             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2138                         ? *SP : sv_mortalcopy(*SP);
2139         else
2140             *++newsp = &PL_sv_undef;
2141     }
2142     else if (gimme == G_ARRAY) {
2143         while (++MARK <= SP) {
2144             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2145                         ? *MARK : sv_mortalcopy(*MARK);
2146             TAINT_NOT;          /* Each item is independent */
2147         }
2148     }
2149     SP = newsp;
2150     PUTBACK;
2151
2152     LEAVE;
2153     cxstack_ix--;
2154     /* Stack values are safe: */
2155     switch (pop2) {
2156     case CXt_LOOP:
2157         POPLOOP(cx);    /* release loop vars ... */
2158         LEAVE;
2159         break;
2160     case CXt_SUB:
2161         POPSUB(cx,sv);  /* release CV and @_ ... */
2162         break;
2163     }
2164     PL_curpm = newpm;   /* ... and pop $1 et al */
2165
2166     LEAVESUB(sv);
2167     PERL_UNUSED_VAR(optype);
2168     PERL_UNUSED_VAR(gimme);
2169     return nextop;
2170 }
2171
2172 PP(pp_next)
2173 {
2174     dVAR;
2175     I32 cxix;
2176     register PERL_CONTEXT *cx;
2177     I32 inner;
2178
2179     if (PL_op->op_flags & OPf_SPECIAL) {
2180         cxix = dopoptoloop(cxstack_ix);
2181         if (cxix < 0)
2182             DIE(aTHX_ "Can't \"next\" outside a loop block");
2183     }
2184     else {
2185         cxix = dopoptolabel(cPVOP->op_pv);
2186         if (cxix < 0)
2187             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2188     }
2189     if (cxix < cxstack_ix)
2190         dounwind(cxix);
2191
2192     /* clear off anything above the scope we're re-entering, but
2193      * save the rest until after a possible continue block */
2194     inner = PL_scopestack_ix;
2195     TOPBLOCK(cx);
2196     if (PL_scopestack_ix < inner)
2197         leave_scope(PL_scopestack[PL_scopestack_ix]);
2198     PL_curcop = cx->blk_oldcop;
2199     return CX_LOOP_NEXTOP_GET(cx);
2200 }
2201
2202 PP(pp_redo)
2203 {
2204     dVAR;
2205     I32 cxix;
2206     register PERL_CONTEXT *cx;
2207     I32 oldsave;
2208     OP* redo_op;
2209
2210     if (PL_op->op_flags & OPf_SPECIAL) {
2211         cxix = dopoptoloop(cxstack_ix);
2212         if (cxix < 0)
2213             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2214     }
2215     else {
2216         cxix = dopoptolabel(cPVOP->op_pv);
2217         if (cxix < 0)
2218             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2219     }
2220     if (cxix < cxstack_ix)
2221         dounwind(cxix);
2222
2223     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2224     if (redo_op->op_type == OP_ENTER) {
2225         /* pop one less context to avoid $x being freed in while (my $x..) */
2226         cxstack_ix++;
2227         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2228         redo_op = redo_op->op_next;
2229     }
2230
2231     TOPBLOCK(cx);
2232     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2233     LEAVE_SCOPE(oldsave);
2234     FREETMPS;
2235     PL_curcop = cx->blk_oldcop;
2236     return redo_op;
2237 }
2238
2239 STATIC OP *
2240 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2241 {
2242     dVAR;
2243     OP **ops = opstack;
2244     static const char too_deep[] = "Target of goto is too deeply nested";
2245
2246     if (ops >= oplimit)
2247         Perl_croak(aTHX_ too_deep);
2248     if (o->op_type == OP_LEAVE ||
2249         o->op_type == OP_SCOPE ||
2250         o->op_type == OP_LEAVELOOP ||
2251         o->op_type == OP_LEAVESUB ||
2252         o->op_type == OP_LEAVETRY)
2253     {
2254         *ops++ = cUNOPo->op_first;
2255         if (ops >= oplimit)
2256             Perl_croak(aTHX_ too_deep);
2257     }
2258     *ops = 0;
2259     if (o->op_flags & OPf_KIDS) {
2260         OP *kid;
2261         /* First try all the kids at this level, since that's likeliest. */
2262         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2263             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2264                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2265                 return kid;
2266         }
2267         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2268             if (kid == PL_lastgotoprobe)
2269                 continue;
2270             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2271                 if (ops == opstack)
2272                     *ops++ = kid;
2273                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2274                          ops[-1]->op_type == OP_DBSTATE)
2275                     ops[-1] = kid;
2276                 else
2277                     *ops++ = kid;
2278             }
2279             if ((o = dofindlabel(kid, label, ops, oplimit)))
2280                 return o;
2281         }
2282     }
2283     *ops = 0;
2284     return 0;
2285 }
2286
2287 PP(pp_goto)
2288 {
2289     dVAR; dSP;
2290     OP *retop = NULL;
2291     I32 ix;
2292     register PERL_CONTEXT *cx;
2293 #define GOTO_DEPTH 64
2294     OP *enterops[GOTO_DEPTH];
2295     const char *label = NULL;
2296     const bool do_dump = (PL_op->op_type == OP_DUMP);
2297     static const char must_have_label[] = "goto must have label";
2298
2299     if (PL_op->op_flags & OPf_STACKED) {
2300         SV * const sv = POPs;
2301
2302         /* This egregious kludge implements goto &subroutine */
2303         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2304             I32 cxix;
2305             register PERL_CONTEXT *cx;
2306             CV* cv = (CV*)SvRV(sv);
2307             SV** mark;
2308             I32 items = 0;
2309             I32 oldsave;
2310             bool reified = 0;
2311
2312         retry:
2313             if (!CvROOT(cv) && !CvXSUB(cv)) {
2314                 const GV * const gv = CvGV(cv);
2315                 if (gv) {
2316                     GV *autogv;
2317                     SV *tmpstr;
2318                     /* autoloaded stub? */
2319                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2320                         goto retry;
2321                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2322                                           GvNAMELEN(gv), FALSE);
2323                     if (autogv && (cv = GvCV(autogv)))
2324                         goto retry;
2325                     tmpstr = sv_newmortal();
2326                     gv_efullname3(tmpstr, gv, NULL);
2327                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2328                 }
2329                 DIE(aTHX_ "Goto undefined subroutine");
2330             }
2331
2332             /* First do some returnish stuff. */
2333             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2334             FREETMPS;
2335             cxix = dopoptosub(cxstack_ix);
2336             if (cxix < 0)
2337                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2338             if (cxix < cxstack_ix)
2339                 dounwind(cxix);
2340             TOPBLOCK(cx);
2341             SPAGAIN;
2342             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2343             if (CxTYPE(cx) == CXt_EVAL) {
2344                 if (CxREALEVAL(cx))
2345                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2346                 else
2347                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2348             }
2349             else if (CxMULTICALL(cx))
2350                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2351             if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
2352                 /* put @_ back onto stack */
2353                 AV* av = cx->blk_sub.argarray;
2354
2355                 items = AvFILLp(av) + 1;
2356                 EXTEND(SP, items+1); /* @_ could have been extended. */
2357                 Copy(AvARRAY(av), SP + 1, items, SV*);
2358                 SvREFCNT_dec(GvAV(PL_defgv));
2359                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2360                 CLEAR_ARGARRAY(av);
2361                 /* abandon @_ if it got reified */
2362                 if (AvREAL(av)) {
2363                     reified = 1;
2364                     SvREFCNT_dec(av);
2365                     av = newAV();
2366                     av_extend(av, items-1);
2367                     AvREIFY_only(av);
2368                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2369                 }
2370             }
2371             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2372                 AV* const av = GvAV(PL_defgv);
2373                 items = AvFILLp(av) + 1;
2374                 EXTEND(SP, items+1); /* @_ could have been extended. */
2375                 Copy(AvARRAY(av), SP + 1, items, SV*);
2376             }
2377             mark = SP;
2378             SP += items;
2379             if (CxTYPE(cx) == CXt_SUB &&
2380                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2381                 SvREFCNT_dec(cx->blk_sub.cv);
2382             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2383             LEAVE_SCOPE(oldsave);
2384
2385             /* Now do some callish stuff. */
2386             SAVETMPS;
2387             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2388             if (CvISXSUB(cv)) {
2389                 OP* const retop = cx->blk_sub.retop;
2390                 SV **newsp;
2391                 I32 gimme;
2392                 if (reified) {
2393                     I32 index;
2394                     for (index=0; index<items; index++)
2395                         sv_2mortal(SP[-index]);
2396                 }
2397
2398                 /* XS subs don't have a CxSUB, so pop it */
2399                 POPBLOCK(cx, PL_curpm);
2400                 /* Push a mark for the start of arglist */
2401                 PUSHMARK(mark);
2402                 PUTBACK;
2403                 (void)(*CvXSUB(cv))(aTHX_ cv);
2404                 LEAVE;
2405                 return retop;
2406             }
2407             else {
2408                 AV* const padlist = CvPADLIST(cv);
2409                 if (CxTYPE(cx) == CXt_EVAL) {
2410                     PL_in_eval = cx->blk_eval.old_in_eval;
2411                     PL_eval_root = cx->blk_eval.old_eval_root;
2412                     cx->cx_type = CXt_SUB;
2413                     cx->blk_sub.hasargs = 0;
2414                 }
2415                 cx->blk_sub.cv = cv;
2416                 cx->blk_sub.olddepth = CvDEPTH(cv);
2417
2418                 CvDEPTH(cv)++;
2419                 if (CvDEPTH(cv) < 2)
2420                     SvREFCNT_inc_simple_void_NN(cv);
2421                 else {
2422                     if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
2423                         sub_crush_depth(cv);
2424                     pad_push(padlist, CvDEPTH(cv));
2425                 }
2426                 SAVECOMPPAD();
2427                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2428                 if (cx->blk_sub.hasargs)
2429                 {
2430                     AV* const av = (AV*)PAD_SVl(0);
2431
2432                     cx->blk_sub.savearray = GvAV(PL_defgv);
2433                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2434                     CX_CURPAD_SAVE(cx->blk_sub);
2435                     cx->blk_sub.argarray = av;
2436
2437                     if (items >= AvMAX(av) + 1) {
2438                         SV **ary = AvALLOC(av);
2439                         if (AvARRAY(av) != ary) {
2440                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2441                             AvARRAY(av) = ary;
2442                         }
2443                         if (items >= AvMAX(av) + 1) {
2444                             AvMAX(av) = items - 1;
2445                             Renew(ary,items+1,SV*);
2446                             AvALLOC(av) = ary;
2447                             AvARRAY(av) = ary;
2448                         }
2449                     }
2450                     ++mark;
2451                     Copy(mark,AvARRAY(av),items,SV*);
2452                     AvFILLp(av) = items - 1;
2453                     assert(!AvREAL(av));
2454                     if (reified) {
2455                         /* transfer 'ownership' of refcnts to new @_ */
2456                         AvREAL_on(av);
2457                         AvREIFY_off(av);
2458                     }
2459                     while (items--) {
2460                         if (*mark)
2461                             SvTEMP_off(*mark);
2462                         mark++;
2463                     }
2464                 }
2465                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2466                     Perl_get_db_sub(aTHX_ NULL, cv);
2467                     if (PERLDB_GOTO) {
2468                         CV * const gotocv = get_cv("DB::goto", FALSE);
2469                         if (gotocv) {
2470                             PUSHMARK( PL_stack_sp );
2471                             call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2472                             PL_stack_sp--;
2473                         }
2474                     }
2475                 }
2476                 RETURNOP(CvSTART(cv));
2477             }
2478         }
2479         else {
2480             label = SvPV_nolen_const(sv);
2481             if (!(do_dump || *label))
2482                 DIE(aTHX_ must_have_label);
2483         }
2484     }
2485     else if (PL_op->op_flags & OPf_SPECIAL) {
2486         if (! do_dump)
2487             DIE(aTHX_ must_have_label);
2488     }
2489     else
2490         label = cPVOP->op_pv;
2491
2492     if (label && *label) {
2493         OP *gotoprobe = NULL;
2494         bool leaving_eval = FALSE;
2495         bool in_block = FALSE;
2496         PERL_CONTEXT *last_eval_cx = NULL;
2497
2498         /* find label */
2499
2500         PL_lastgotoprobe = NULL;
2501         *enterops = 0;
2502         for (ix = cxstack_ix; ix >= 0; ix--) {
2503             cx = &cxstack[ix];
2504             switch (CxTYPE(cx)) {
2505             case CXt_EVAL:
2506                 leaving_eval = TRUE;
2507                 if (!CxTRYBLOCK(cx)) {
2508                     gotoprobe = (last_eval_cx ?
2509                                 last_eval_cx->blk_eval.old_eval_root :
2510                                 PL_eval_root);
2511                     last_eval_cx = cx;
2512                     break;
2513                 }
2514                 /* else fall through */
2515             case CXt_LOOP:
2516                 gotoprobe = cx->blk_oldcop->op_sibling;
2517                 break;
2518             case CXt_SUBST:
2519                 continue;
2520             case CXt_BLOCK:
2521                 if (ix) {
2522                     gotoprobe = cx->blk_oldcop->op_sibling;
2523                     in_block = TRUE;
2524                 } else
2525                     gotoprobe = PL_main_root;
2526                 break;
2527             case CXt_SUB:
2528                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2529                     gotoprobe = CvROOT(cx->blk_sub.cv);
2530                     break;
2531                 }
2532                 /* FALL THROUGH */
2533             case CXt_FORMAT:
2534             case CXt_NULL:
2535                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2536             default:
2537                 if (ix)
2538                     DIE(aTHX_ "panic: goto");
2539                 gotoprobe = PL_main_root;
2540                 break;
2541             }
2542             if (gotoprobe) {
2543                 retop = dofindlabel(gotoprobe, label,
2544                                     enterops, enterops + GOTO_DEPTH);
2545                 if (retop)
2546                     break;
2547             }
2548             PL_lastgotoprobe = gotoprobe;
2549         }
2550         if (!retop)
2551             DIE(aTHX_ "Can't find label %s", label);
2552
2553         /* if we're leaving an eval, check before we pop any frames
2554            that we're not going to punt, otherwise the error
2555            won't be caught */
2556
2557         if (leaving_eval && *enterops && enterops[1]) {
2558             I32 i;
2559             for (i = 1; enterops[i]; i++)
2560                 if (enterops[i]->op_type == OP_ENTERITER)
2561                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2562         }
2563
2564         /* pop unwanted frames */
2565
2566         if (ix < cxstack_ix) {
2567             I32 oldsave;
2568
2569             if (ix < 0)
2570                 ix = 0;
2571             dounwind(ix);
2572             TOPBLOCK(cx);
2573             oldsave = PL_scopestack[PL_scopestack_ix];
2574             LEAVE_SCOPE(oldsave);
2575         }
2576
2577         /* push wanted frames */
2578
2579         if (*enterops && enterops[1]) {
2580             OP * const oldop = PL_op;
2581             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2582             for (; enterops[ix]; ix++) {
2583                 PL_op = enterops[ix];
2584                 /* Eventually we may want to stack the needed arguments
2585                  * for each op.  For now, we punt on the hard ones. */
2586                 if (PL_op->op_type == OP_ENTERITER)
2587                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2588                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2589             }
2590             PL_op = oldop;
2591         }
2592     }
2593
2594     if (do_dump) {
2595 #ifdef VMS
2596         if (!retop) retop = PL_main_start;
2597 #endif
2598         PL_restartop = retop;
2599         PL_do_undump = TRUE;
2600
2601         my_unexec();
2602
2603         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2604         PL_do_undump = FALSE;
2605     }
2606
2607     RETURNOP(retop);
2608 }
2609
2610 PP(pp_exit)
2611 {
2612     dVAR;
2613     dSP;
2614     I32 anum;
2615
2616     if (MAXARG < 1)
2617         anum = 0;
2618     else {
2619         anum = SvIVx(POPs);
2620 #ifdef VMS
2621         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2622             anum = 0;
2623         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2624 #endif
2625     }
2626     PL_exit_flags |= PERL_EXIT_EXPECTED;
2627 #ifdef PERL_MAD
2628     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2629     if (anum || !(PL_minus_c && PL_madskills))
2630         my_exit(anum);
2631 #else
2632     my_exit(anum);
2633 #endif
2634     PUSHs(&PL_sv_undef);
2635     RETURN;
2636 }
2637
2638 /* Eval. */
2639
2640 STATIC void
2641 S_save_lines(pTHX_ AV *array, SV *sv)
2642 {
2643     const char *s = SvPVX_const(sv);
2644     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2645     I32 line = 1;
2646
2647     while (s && s < send) {
2648         const char *t;
2649         SV * const tmpstr = newSV_type(SVt_PVMG);
2650
2651         t = strchr(s, '\n');
2652         if (t)
2653             t++;
2654         else
2655             t = send;
2656
2657         sv_setpvn(tmpstr, s, t - s);
2658         av_store(array, line++, tmpstr);
2659         s = t;
2660     }
2661 }
2662
2663 STATIC void
2664 S_docatch_body(pTHX)
2665 {
2666     dVAR;
2667     CALLRUNOPS(aTHX);
2668     return;
2669 }
2670
2671 STATIC OP *
2672 S_docatch(pTHX_ OP *o)
2673 {
2674     dVAR;
2675     int ret;
2676     OP * const oldop = PL_op;
2677     dJMPENV;
2678
2679 #ifdef DEBUGGING
2680     assert(CATCH_GET == TRUE);
2681 #endif
2682     PL_op = o;
2683
2684     JMPENV_PUSH(ret);
2685     switch (ret) {
2686     case 0:
2687         assert(cxstack_ix >= 0);
2688         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2689         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2690  redo_body:
2691         docatch_body();
2692         break;
2693     case 3:
2694         /* die caught by an inner eval - continue inner loop */
2695
2696         /* NB XXX we rely on the old popped CxEVAL still being at the top
2697          * of the stack; the way die_where() currently works, this
2698          * assumption is valid. In theory The cur_top_env value should be
2699          * returned in another global, the way retop (aka PL_restartop)
2700          * is. */
2701         assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2702
2703         if (PL_restartop
2704             && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2705         {
2706             PL_op = PL_restartop;
2707             PL_restartop = 0;
2708             goto redo_body;
2709         }
2710         /* FALL THROUGH */
2711     default:
2712         JMPENV_POP;
2713         PL_op = oldop;
2714         JMPENV_JUMP(ret);
2715         /* NOTREACHED */
2716     }
2717     JMPENV_POP;
2718     PL_op = oldop;
2719     return NULL;
2720 }
2721
2722 OP *
2723 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2724 /* sv Text to convert to OP tree. */
2725 /* startop op_free() this to undo. */
2726 /* code Short string id of the caller. */
2727 {
2728     /* FIXME - how much of this code is common with pp_entereval?  */
2729     dVAR; dSP;                          /* Make POPBLOCK work. */
2730     PERL_CONTEXT *cx;
2731     SV **newsp;
2732     I32 gimme = G_VOID;
2733     I32 optype;
2734     OP dummy;
2735     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2736     char *tmpbuf = tbuf;
2737     char *safestr;
2738     int runtime;
2739     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
2740     STRLEN len;
2741
2742     ENTER;
2743     lex_start(sv, NULL, FALSE);
2744     SAVETMPS;
2745     /* switch to eval mode */
2746
2747     if (IN_PERL_COMPILETIME) {
2748         SAVECOPSTASH_FREE(&PL_compiling);
2749         CopSTASH_set(&PL_compiling, PL_curstash);
2750     }
2751     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2752         SV * const sv = sv_newmortal();
2753         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2754                        code, (unsigned long)++PL_evalseq,
2755                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2756         tmpbuf = SvPVX(sv);
2757         len = SvCUR(sv);
2758     }
2759     else
2760         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2761                           (unsigned long)++PL_evalseq);
2762     SAVECOPFILE_FREE(&PL_compiling);
2763     CopFILE_set(&PL_compiling, tmpbuf+2);
2764     SAVECOPLINE(&PL_compiling);
2765     CopLINE_set(&PL_compiling, 1);
2766     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2767        deleting the eval's FILEGV from the stash before gv_check() runs
2768        (i.e. before run-time proper). To work around the coredump that
2769        ensues, we always turn GvMULTI_on for any globals that were
2770        introduced within evals. See force_ident(). GSAR 96-10-12 */
2771     safestr = savepvn(tmpbuf, len);
2772     SAVEDELETE(PL_defstash, safestr, len);
2773     SAVEHINTS();
2774 #ifdef OP_IN_REGISTER
2775     PL_opsave = op;
2776 #else
2777     SAVEVPTR(PL_op);
2778 #endif
2779
2780     /* we get here either during compilation, or via pp_regcomp at runtime */
2781     runtime = IN_PERL_RUNTIME;
2782     if (runtime)
2783         runcv = find_runcv(NULL);
2784
2785     PL_op = &dummy;
2786     PL_op->op_type = OP_ENTEREVAL;
2787     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2788     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2789     PUSHEVAL(cx, 0, NULL);
2790
2791     if (runtime)
2792         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2793     else
2794         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2795     POPBLOCK(cx,PL_curpm);
2796     POPEVAL(cx);
2797
2798     (*startop)->op_type = OP_NULL;
2799     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2800     lex_end();
2801     /* XXX DAPM do this properly one year */
2802     *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2803     LEAVE;
2804     if (IN_PERL_COMPILETIME)
2805         CopHINTS_set(&PL_compiling, PL_hints);
2806 #ifdef OP_IN_REGISTER
2807     op = PL_opsave;
2808 #endif
2809     PERL_UNUSED_VAR(newsp);
2810     PERL_UNUSED_VAR(optype);
2811
2812     return PL_eval_start;
2813 }
2814
2815
2816 /*
2817 =for apidoc find_runcv
2818
2819 Locate the CV corresponding to the currently executing sub or eval.
2820 If db_seqp is non_null, skip CVs that are in the DB package and populate
2821 *db_seqp with the cop sequence number at the point that the DB:: code was
2822 entered. (allows debuggers to eval in the scope of the breakpoint rather
2823 than in the scope of the debugger itself).
2824
2825 =cut
2826 */
2827
2828 CV*
2829 Perl_find_runcv(pTHX_ U32 *db_seqp)
2830 {
2831     dVAR;
2832     PERL_SI      *si;
2833
2834     if (db_seqp)
2835         *db_seqp = PL_curcop->cop_seq;
2836     for (si = PL_curstackinfo; si; si = si->si_prev) {
2837         I32 ix;
2838         for (ix = si->si_cxix; ix >= 0; ix--) {
2839             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2840             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2841                 CV * const cv = cx->blk_sub.cv;
2842                 /* skip DB:: code */
2843                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2844                     *db_seqp = cx->blk_oldcop->cop_seq;
2845                     continue;
2846                 }
2847                 return cv;
2848             }
2849             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2850                 return PL_compcv;
2851         }
2852     }
2853     return PL_main_cv;
2854 }
2855
2856
2857 /* Compile a require/do, an eval '', or a /(?{...})/.
2858  * In the last case, startop is non-null, and contains the address of
2859  * a pointer that should be set to the just-compiled code.
2860  * outside is the lexically enclosing CV (if any) that invoked us.
2861  * Returns a bool indicating whether the compile was successful; if so,
2862  * PL_eval_start contains the first op of the compiled ocde; otherwise,
2863  * pushes undef (also croaks if startop != NULL).
2864  */
2865
2866 STATIC bool
2867 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2868 {
2869     dVAR; dSP;
2870     OP * const saveop = PL_op;
2871
2872     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2873                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2874                   : EVAL_INEVAL);
2875
2876     PUSHMARK(SP);
2877
2878     SAVESPTR(PL_compcv);
2879     PL_compcv = (CV*)newSV_type(SVt_PVCV);
2880     CvEVAL_on(PL_compcv);
2881     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2882     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2883
2884     CvOUTSIDE_SEQ(PL_compcv) = seq;
2885     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2886
2887     /* set up a scratch pad */
2888
2889     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2890     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2891
2892
2893     if (!PL_madskills)
2894         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
2895
2896     /* make sure we compile in the right package */
2897
2898     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2899         SAVESPTR(PL_curstash);
2900         PL_curstash = CopSTASH(PL_curcop);
2901     }
2902     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2903     SAVESPTR(PL_beginav);
2904     PL_beginav = newAV();
2905     SAVEFREESV(PL_beginav);
2906     SAVESPTR(PL_unitcheckav);
2907     PL_unitcheckav = newAV();
2908     SAVEFREESV(PL_unitcheckav);
2909
2910 #ifdef PERL_MAD
2911     SAVEBOOL(PL_madskills);
2912     PL_madskills = 0;
2913 #endif
2914
2915     /* try to compile it */
2916
2917     PL_eval_root = NULL;
2918     PL_curcop = &PL_compiling;
2919     CopARYBASE_set(PL_curcop, 0);
2920     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2921         PL_in_eval |= EVAL_KEEPERR;
2922     else
2923         sv_setpvn(ERRSV,"",0);
2924     if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2925         SV **newsp;                     /* Used by POPBLOCK. */
2926         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2927         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2928         const char *msg;
2929
2930         PL_op = saveop;
2931         if (PL_eval_root) {
2932             op_free(PL_eval_root);
2933             PL_eval_root = NULL;
2934         }
2935         SP = PL_stack_base + POPMARK;           /* pop original mark */
2936         if (!startop) {
2937             POPBLOCK(cx,PL_curpm);
2938             POPEVAL(cx);
2939         }
2940         lex_end();
2941         LEAVE;
2942
2943         msg = SvPVx_nolen_const(ERRSV);
2944         if (optype == OP_REQUIRE) {
2945             const SV * const nsv = cx->blk_eval.old_namesv;
2946             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2947                           &PL_sv_undef, 0);
2948             Perl_croak(aTHX_ "%sCompilation failed in require",
2949                        *msg ? msg : "Unknown error\n");
2950         }
2951         else if (startop) {
2952             POPBLOCK(cx,PL_curpm);
2953             POPEVAL(cx);
2954             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2955                        (*msg ? msg : "Unknown error\n"));
2956         }
2957         else {
2958             if (!*msg) {
2959                 sv_setpvs(ERRSV, "Compilation error");
2960             }
2961         }
2962         PERL_UNUSED_VAR(newsp);
2963         PUSHs(&PL_sv_undef);
2964         PUTBACK;
2965         return FALSE;
2966     }
2967     CopLINE_set(&PL_compiling, 0);
2968     if (startop) {
2969         *startop = PL_eval_root;
2970     } else
2971         SAVEFREEOP(PL_eval_root);
2972
2973     /* Set the context for this new optree.
2974      * If the last op is an OP_REQUIRE, force scalar context.
2975      * Otherwise, propagate the context from the eval(). */
2976     if (PL_eval_root->op_type == OP_LEAVEEVAL
2977             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2978             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2979             == OP_REQUIRE)
2980         scalar(PL_eval_root);
2981     else if (gimme & G_VOID)
2982         scalarvoid(PL_eval_root);
2983     else if (gimme & G_ARRAY)
2984         list(PL_eval_root);
2985     else
2986         scalar(PL_eval_root);
2987
2988     DEBUG_x(dump_eval());
2989
2990     /* Register with debugger: */
2991     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
2992         CV * const cv = get_cv("DB::postponed", FALSE);
2993         if (cv) {
2994             dSP;
2995             PUSHMARK(SP);
2996             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2997             PUTBACK;
2998             call_sv((SV*)cv, G_DISCARD);
2999         }
3000     }
3001
3002     if (PL_unitcheckav)
3003         call_list(PL_scopestack_ix, PL_unitcheckav);
3004
3005     /* compiled okay, so do it */
3006
3007     CvDEPTH(PL_compcv) = 1;
3008     SP = PL_stack_base + POPMARK;               /* pop original mark */
3009     PL_op = saveop;                     /* The caller may need it. */
3010     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3011
3012     PUTBACK;
3013     return TRUE;
3014 }
3015
3016 STATIC PerlIO *
3017 S_check_type_and_open(pTHX_ const char *name, const char *mode)
3018 {
3019     Stat_t st;
3020     const int st_rc = PerlLIO_stat(name, &st);
3021
3022     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3023         return NULL;
3024     }
3025
3026     return PerlIO_open(name, mode);
3027 }
3028
3029 STATIC PerlIO *
3030 S_doopen_pm(pTHX_ const char *name, const char *mode)
3031 {
3032 #ifndef PERL_DISABLE_PMC
3033     const STRLEN namelen = strlen(name);
3034     PerlIO *fp;
3035
3036     if (namelen > 3 && strEQ(name + namelen - 3, ".pm")) {
3037         SV * const pmcsv = Perl_newSVpvf(aTHX_ "%s%c", name, 'c');
3038         const char * const pmc = SvPV_nolen_const(pmcsv);
3039         Stat_t pmcstat;
3040         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3041             fp = check_type_and_open(name, mode);
3042         }
3043         else {
3044             fp = check_type_and_open(pmc, mode);
3045         }
3046         SvREFCNT_dec(pmcsv);
3047     }
3048     else {
3049         fp = check_type_and_open(name, mode);
3050     }
3051     return fp;
3052 #else
3053     return check_type_and_open(name, mode);
3054 #endif /* !PERL_DISABLE_PMC */
3055 }
3056
3057 PP(pp_require)
3058 {
3059     dVAR; dSP;
3060     register PERL_CONTEXT *cx;
3061     SV *sv;
3062     const char *name;
3063     STRLEN len;
3064     char * unixname;
3065     STRLEN unixlen;
3066 #ifdef VMS
3067     int vms_unixname = 0;
3068 #endif
3069     const char *tryname = NULL;
3070     SV *namesv = NULL;
3071     const I32 gimme = GIMME_V;
3072     int filter_has_file = 0;
3073     PerlIO *tryrsfp = NULL;
3074     SV *filter_cache = NULL;
3075     SV *filter_state = NULL;
3076     SV *filter_sub = NULL;
3077     SV *hook_sv = NULL;
3078     SV *encoding;
3079     OP *op;
3080
3081     sv = POPs;
3082     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3083         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) {     /* require v5.6.1 */
3084             HV * hinthv = GvHV(PL_hintgv);
3085             SV ** ptr = NULL;
3086             if (hinthv) ptr = hv_fetchs(hinthv, "v_string", FALSE);
3087             if ( !(ptr && *ptr && SvIOK(*ptr) && SvIV(*ptr)) )
3088                 Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
3089                         "v-string in use/require non-portable");
3090         }
3091         sv = new_version(sv);
3092         if (!sv_derived_from(PL_patchlevel, "version"))
3093             upg_version(PL_patchlevel, TRUE);
3094         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3095             if ( vcmp(sv,PL_patchlevel) <= 0 )
3096                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3097                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3098         }
3099         else {
3100             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3101                 I32 first = 0;
3102                 AV *lav;
3103                 SV * const req = SvRV(sv);
3104                 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3105
3106                 /* get the left hand term */
3107                 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3108
3109                 first  = SvIV(*av_fetch(lav,0,0));
3110                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3111                     || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3112                     || av_len(lav) > 1               /* FP with > 3 digits */
3113                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3114                    ) {
3115                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3116                         "%"SVf", stopped", SVfARG(vnormal(req)),
3117                         SVfARG(vnormal(PL_patchlevel)));
3118                 }
3119                 else { /* probably 'use 5.10' or 'use 5.8' */
3120                     SV * hintsv = newSV(0);
3121                     I32 second = 0;
3122
3123                     if (av_len(lav)>=1)
3124                         second = SvIV(*av_fetch(lav,1,0));
3125
3126                     second /= second >= 600  ? 100 : 10;
3127                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3128                         (int)first, (int)second,0);
3129                     upg_version(hintsv, TRUE);
3130
3131                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3132                         "--this is only %"SVf", stopped",
3133                         SVfARG(vnormal(req)),
3134                         SVfARG(vnormal(hintsv)),
3135                         SVfARG(vnormal(PL_patchlevel)));
3136                 }
3137             }
3138         }
3139
3140         /* We do this only with use, not require. */
3141         if (PL_compcv &&
3142           /* If we request a version >= 5.6.0, then v-string are OK
3143              so set $^H{v_string} to suppress the v-string warning */
3144             vcmp(sv, sv_2mortal(upg_version(newSVnv(5.006), FALSE))) >= 0) {
3145           HV * hinthv = GvHV(PL_hintgv);
3146           if( hinthv ) {
3147             (void)hv_stores(hinthv, "v_string", newSViv(1));
3148             PL_hints |= HINT_LOCALIZE_HH;
3149           }
3150           /* If we request a version >= 5.9.5, load feature.pm with the
3151            * feature bundle that corresponds to the required version. */
3152           if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3153             SV *const importsv = vnormal(sv);
3154             *SvPVX_mutable(importsv) = ':';
3155             ENTER;
3156             Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3157             LEAVE;
3158           }
3159         }
3160
3161         RETPUSHYES;
3162     }
3163     name = SvPV_const(sv, len);
3164     if (!(name && len > 0 && *name))
3165         DIE(aTHX_ "Null filename used");
3166     TAINT_PROPER("require");
3167
3168
3169 #ifdef VMS
3170     /* The key in the %ENV hash is in the syntax of file passed as the argument
3171      * usually this is in UNIX format, but sometimes in VMS format, which
3172      * can result in a module being pulled in more than once.
3173      * To prevent this, the key must be stored in UNIX format if the VMS
3174      * name can be translated to UNIX.
3175      */
3176     if ((unixname = tounixspec(name, NULL)) != NULL) {
3177         unixlen = strlen(unixname);
3178         vms_unixname = 1;
3179     }
3180     else
3181 #endif
3182     {
3183         /* if not VMS or VMS name can not be translated to UNIX, pass it
3184          * through.
3185          */
3186         unixname = (char *) name;
3187         unixlen = len;
3188     }
3189     if (PL_op->op_type == OP_REQUIRE) {
3190         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3191                                           unixname, unixlen, 0);
3192         if ( svp ) {
3193             if (*svp != &PL_sv_undef)
3194                 RETPUSHYES;
3195             else
3196                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3197                             "Compilation failed in require", unixname);
3198         }
3199     }
3200
3201     /* prepare to compile file */
3202
3203     if (path_is_absolute(name)) {
3204         tryname = name;
3205         tryrsfp = doopen_pm(name,PERL_SCRIPT_MODE);
3206     }
3207 #ifdef MACOS_TRADITIONAL
3208     if (!tryrsfp) {
3209         char newname[256];
3210
3211         MacPerl_CanonDir(name, newname, 1);
3212         if (path_is_absolute(newname)) {
3213             tryname = newname;
3214             tryrsfp = doopen_pm(newname,PERL_SCRIPT_MODE);
3215         }
3216     }
3217 #endif
3218     if (!tryrsfp) {
3219         AV * const ar = GvAVn(PL_incgv);
3220         I32 i;
3221 #ifdef VMS
3222         if (vms_unixname)
3223 #endif
3224         {
3225             namesv = newSV(0);
3226             for (i = 0; i <= AvFILL(ar); i++) {
3227                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3228
3229                 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3230                     mg_get(dirsv);
3231                 if (SvROK(dirsv)) {
3232                     int count;
3233                     SV **svp;
3234                     SV *loader = dirsv;
3235
3236                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3237                         && !sv_isobject(loader))
3238                     {
3239                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3240                     }
3241
3242                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3243                                    PTR2UV(SvRV(dirsv)), name);
3244                     tryname = SvPVX_const(namesv);
3245                     tryrsfp = NULL;
3246
3247                     ENTER;
3248                     SAVETMPS;
3249                     EXTEND(SP, 2);
3250
3251                     PUSHMARK(SP);
3252                     PUSHs(dirsv);
3253                     PUSHs(sv);
3254                     PUTBACK;
3255                     if (sv_isobject(loader))
3256                         count = call_method("INC", G_ARRAY);
3257                     else
3258                         count = call_sv(loader, G_ARRAY);
3259                     SPAGAIN;
3260
3261                     /* Adjust file name if the hook has set an %INC entry */
3262                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3263                     if (svp)
3264                         tryname = SvPVX_const(*svp);
3265
3266                     if (count > 0) {
3267                         int i = 0;
3268                         SV *arg;
3269
3270                         SP -= count - 1;
3271                         arg = SP[i++];
3272
3273                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3274                             && !isGV_with_GP(SvRV(arg))) {
3275                             filter_cache = SvRV(arg);
3276                             SvREFCNT_inc_simple_void_NN(filter_cache);
3277
3278                             if (i < count) {
3279                                 arg = SP[i++];
3280                             }
3281                         }
3282
3283                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3284                             arg = SvRV(arg);
3285                         }
3286
3287                         if (SvTYPE(arg) == SVt_PVGV) {
3288                             IO * const io = GvIO((GV *)arg);
3289
3290                             ++filter_has_file;
3291
3292                             if (io) {
3293                                 tryrsfp = IoIFP(io);
3294                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3295                                     PerlIO_close(IoOFP(io));
3296                                 }
3297                                 IoIFP(io) = NULL;
3298                                 IoOFP(io) = NULL;
3299                             }
3300
3301                             if (i < count) {
3302                                 arg = SP[i++];
3303                             }
3304                         }
3305
3306                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3307                             filter_sub = arg;
3308                             SvREFCNT_inc_simple_void_NN(filter_sub);
3309
3310                             if (i < count) {
3311                                 filter_state = SP[i];
3312                                 SvREFCNT_inc_simple_void(filter_state);
3313                             }
3314                         }
3315
3316                         if (!tryrsfp && (filter_cache || filter_sub)) {
3317                             tryrsfp = PerlIO_open(BIT_BUCKET,
3318                                                   PERL_SCRIPT_MODE);
3319                         }
3320                         SP--;
3321                     }
3322
3323                     PUTBACK;
3324                     FREETMPS;
3325                     LEAVE;
3326
3327                     if (tryrsfp) {
3328                         hook_sv = dirsv;
3329                         break;
3330                     }
3331
3332                     filter_has_file = 0;
3333                     if (filter_cache) {
3334                         SvREFCNT_dec(filter_cache);
3335                         filter_cache = NULL;
3336                     }
3337                     if (filter_state) {
3338                         SvREFCNT_dec(filter_state);
3339                         filter_state = NULL;
3340                     }
3341                     if (filter_sub) {
3342                         SvREFCNT_dec(filter_sub);
3343                         filter_sub = NULL;
3344                     }
3345                 }
3346                 else {
3347                   if (!path_is_absolute(name)
3348 #ifdef MACOS_TRADITIONAL
3349                         /* We consider paths of the form :a:b ambiguous and interpret them first
3350                            as global then as local
3351                         */
3352                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3353 #endif
3354                   ) {
3355                     const char *dir = SvOK(dirsv) ? SvPV_nolen_const(dirsv) : "";
3356 #ifdef MACOS_TRADITIONAL
3357                     char buf1[256];
3358                     char buf2[256];
3359
3360                     MacPerl_CanonDir(name, buf2, 1);
3361                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3362 #else
3363 #  ifdef VMS
3364                     char *unixdir;
3365                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3366                         continue;
3367                     sv_setpv(namesv, unixdir);
3368                     sv_catpv(namesv, unixname);
3369 #  else
3370 #    ifdef __SYMBIAN32__
3371                     if (PL_origfilename[0] &&
3372                         PL_origfilename[1] == ':' &&
3373                         !(dir[0] && dir[1] == ':'))
3374                         Perl_sv_setpvf(aTHX_ namesv,
3375                                        "%c:%s\\%s",
3376                                        PL_origfilename[0],
3377                                        dir, name);
3378                     else
3379                         Perl_sv_setpvf(aTHX_ namesv,
3380                                        "%s\\%s",
3381                                        dir, name);
3382 #    else
3383                     Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3384 #    endif
3385 #  endif
3386 #endif
3387                     TAINT_PROPER("require");
3388                     tryname = SvPVX_const(namesv);
3389                     tryrsfp = doopen_pm(tryname, PERL_SCRIPT_MODE);
3390                     if (tryrsfp) {
3391                         if (tryname[0] == '.' && tryname[1] == '/')
3392                             tryname += 2;
3393                         break;
3394                     }
3395                     else if (errno == EMFILE)
3396                         /* no point in trying other paths if out of handles */
3397                         break;
3398                   }
3399                 }
3400             }
3401         }
3402     }
3403     SAVECOPFILE_FREE(&PL_compiling);
3404     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3405     SvREFCNT_dec(namesv);
3406     if (!tryrsfp) {
3407         if (PL_op->op_type == OP_REQUIRE) {
3408             const char *msgstr = name;
3409             if(errno == EMFILE) {
3410                 SV * const msg
3411                     = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
3412                                                Strerror(errno)));
3413                 msgstr = SvPV_nolen_const(msg);
3414             } else {
3415                 if (namesv) {                   /* did we lookup @INC? */
3416                     AV * const ar = GvAVn(PL_incgv);
3417                     I32 i;
3418                     SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3419                         "%s in @INC%s%s (@INC contains:",
3420                         msgstr,
3421                         (instr(msgstr, ".h ")
3422                          ? " (change .h to .ph maybe?)" : ""),
3423                         (instr(msgstr, ".ph ")
3424                          ? " (did you run h2ph?)" : "")
3425                                                               ));
3426
3427                     for (i = 0; i <= AvFILL(ar); i++) {
3428                         sv_catpvs(msg, " ");
3429                         sv_catsv(msg, *av_fetch(ar, i, TRUE));
3430                     }
3431                     sv_catpvs(msg, ")");
3432                     msgstr = SvPV_nolen_const(msg);
3433                 }
3434             }
3435             DIE(aTHX_ "Can't locate %s", msgstr);
3436         }
3437
3438         RETPUSHUNDEF;
3439     }
3440     else
3441         SETERRNO(0, SS_NORMAL);
3442
3443     /* Assume success here to prevent recursive requirement. */
3444     /* name is never assigned to again, so len is still strlen(name)  */
3445     /* Check whether a hook in @INC has already filled %INC */
3446     if (!hook_sv) {
3447         (void)hv_store(GvHVn(PL_incgv),
3448                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3449     } else {
3450         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3451         if (!svp)
3452             (void)hv_store(GvHVn(PL_incgv),
3453                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3454     }
3455
3456     ENTER;
3457     SAVETMPS;
3458     lex_start(NULL, tryrsfp, TRUE);
3459
3460     SAVEHINTS();
3461     PL_hints = 0;
3462     SAVECOMPILEWARNINGS();
3463     if (PL_dowarn & G_WARN_ALL_ON)
3464         PL_compiling.cop_warnings = pWARN_ALL ;
3465     else if (PL_dowarn & G_WARN_ALL_OFF)
3466         PL_compiling.cop_warnings = pWARN_NONE ;
3467     else
3468         PL_compiling.cop_warnings = pWARN_STD ;
3469
3470     if (filter_sub || filter_cache) {
3471         SV * const datasv = filter_add(S_run_user_filter, NULL);
3472         IoLINES(datasv) = filter_has_file;
3473         IoTOP_GV(datasv) = (GV *)filter_state;
3474         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3475         IoFMT_GV(datasv) = (GV *)filter_cache;
3476     }
3477
3478     /* switch to eval mode */
3479     PUSHBLOCK(cx, CXt_EVAL, SP);
3480     PUSHEVAL(cx, name, NULL);
3481     cx->blk_eval.retop = PL_op->op_next;
3482
3483     SAVECOPLINE(&PL_compiling);
3484     CopLINE_set(&PL_compiling, 0);
3485
3486     PUTBACK;
3487
3488     /* Store and reset encoding. */
3489     encoding = PL_encoding;
3490     PL_encoding = NULL;
3491
3492     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3493         op = DOCATCH(PL_eval_start);
3494     else
3495         op = PL_op->op_next;
3496
3497     /* Restore encoding. */
3498     PL_encoding = encoding;
3499
3500     return op;
3501 }
3502
3503 PP(pp_entereval)
3504 {
3505     dVAR; dSP;
3506     register PERL_CONTEXT *cx;
3507     SV *sv;
3508     const I32 gimme = GIMME_V;
3509     const I32 was = PL_sub_generation;
3510     char tbuf[TYPE_DIGITS(long) + 12];
3511     char *tmpbuf = tbuf;
3512     char *safestr;
3513     STRLEN len;
3514     bool ok;
3515     CV* runcv;
3516     U32 seq;
3517     HV *saved_hh = NULL;
3518     const char * const fakestr = "_<(eval )";
3519     const int fakelen = 9 + 1;
3520
3521     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3522         saved_hh = (HV*) SvREFCNT_inc(POPs);
3523     }
3524     sv = POPs;
3525
3526     TAINT_IF(SvTAINTED(sv));
3527     TAINT_PROPER("eval");
3528
3529     ENTER;
3530     lex_start(sv, NULL, FALSE);
3531     SAVETMPS;
3532
3533     /* switch to eval mode */
3534
3535     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3536         SV * const temp_sv = sv_newmortal();
3537         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3538                        (unsigned long)++PL_evalseq,
3539                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3540         tmpbuf = SvPVX(temp_sv);
3541         len = SvCUR(temp_sv);
3542     }
3543     else
3544         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3545     SAVECOPFILE_FREE(&PL_compiling);
3546     CopFILE_set(&PL_compiling, tmpbuf+2);
3547     SAVECOPLINE(&PL_compiling);
3548     CopLINE_set(&PL_compiling, 1);
3549     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3550        deleting the eval's FILEGV from the stash before gv_check() runs
3551        (i.e. before run-time proper). To work around the coredump that
3552        ensues, we always turn GvMULTI_on for any globals that were
3553        introduced within evals. See force_ident(). GSAR 96-10-12 */
3554     safestr = savepvn(tmpbuf, len);
3555     SAVEDELETE(PL_defstash, safestr, len);
3556     SAVEHINTS();
3557     PL_hints = PL_op->op_targ;
3558     if (saved_hh)
3559         GvHV(PL_hintgv) = saved_hh;
3560     SAVECOMPILEWARNINGS();
3561     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3562     if (PL_compiling.cop_hints_hash) {
3563         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3564     }
3565     PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3566     if (PL_compiling.cop_hints_hash) {
3567         HINTS_REFCNT_LOCK;
3568         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3569         HINTS_REFCNT_UNLOCK;
3570     }
3571     /* special case: an eval '' executed within the DB package gets lexically
3572      * placed in the first non-DB CV rather than the current CV - this
3573      * allows the debugger to execute code, find lexicals etc, in the
3574      * scope of the code being debugged. Passing &seq gets find_runcv
3575      * to do the dirty work for us */
3576     runcv = find_runcv(&seq);
3577
3578     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3579     PUSHEVAL(cx, 0, NULL);
3580     cx->blk_eval.retop = PL_op->op_next;
3581
3582     /* prepare to compile string */
3583
3584     if (PERLDB_LINE && PL_curstash != PL_debstash)
3585         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3586     PUTBACK;
3587     ok = doeval(gimme, NULL, runcv, seq);
3588     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3589         && ok) {
3590         /* Copy in anything fake and short. */
3591         my_strlcpy(safestr, fakestr, fakelen);
3592     }
3593     return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3594 }
3595
3596 PP(pp_leaveeval)
3597 {
3598     dVAR; dSP;
3599     register SV **mark;
3600     SV **newsp;
3601     PMOP *newpm;
3602     I32 gimme;
3603     register PERL_CONTEXT *cx;
3604     OP *retop;
3605     const U8 save_flags = PL_op -> op_flags;
3606     I32 optype;
3607
3608     POPBLOCK(cx,newpm);
3609     POPEVAL(cx);
3610     retop = cx->blk_eval.retop;
3611
3612     TAINT_NOT;
3613     if (gimme == G_VOID)
3614         MARK = newsp;
3615     else if (gimme == G_SCALAR) {
3616         MARK = newsp + 1;
3617         if (MARK <= SP) {
3618             if (SvFLAGS(TOPs) & SVs_TEMP)
3619                 *MARK = TOPs;
3620             else
3621                 *MARK = sv_mortalcopy(TOPs);
3622         }
3623         else {
3624             MEXTEND(mark,0);
3625             *MARK = &PL_sv_undef;
3626         }
3627         SP = MARK;
3628     }
3629     else {
3630         /* in case LEAVE wipes old return values */
3631         for (mark = newsp + 1; mark <= SP; mark++) {
3632             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3633                 *mark = sv_mortalcopy(*mark);
3634                 TAINT_NOT;      /* Each item is independent */
3635             }
3636         }
3637     }
3638     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3639
3640 #ifdef DEBUGGING
3641     assert(CvDEPTH(PL_compcv) == 1);
3642 #endif
3643     CvDEPTH(PL_compcv) = 0;
3644     lex_end();
3645
3646     if (optype == OP_REQUIRE &&
3647         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3648     {
3649         /* Unassume the success we assumed earlier. */
3650         SV * const nsv = cx->blk_eval.old_namesv;
3651         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3652         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3653         /* die_where() did LEAVE, or we won't be here */
3654     }
3655     else {
3656         LEAVE;
3657         if (!(save_flags & OPf_SPECIAL))
3658             sv_setpvn(ERRSV,"",0);
3659     }
3660
3661     RETURNOP(retop);
3662 }
3663
3664 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3665    close to the related Perl_create_eval_scope.  */
3666 void
3667 Perl_delete_eval_scope(pTHX)
3668 {
3669     SV **newsp;
3670     PMOP *newpm;
3671     I32 gimme;
3672     register PERL_CONTEXT *cx;
3673     I32 optype;
3674
3675     POPBLOCK(cx,newpm);
3676     POPEVAL(cx);
3677     PL_curpm = newpm;
3678     LEAVE;
3679     PERL_UNUSED_VAR(newsp);
3680     PERL_UNUSED_VAR(gimme);
3681     PERL_UNUSED_VAR(optype);
3682 }
3683
3684 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3685    also needed by Perl_fold_constants.  */
3686 PERL_CONTEXT *
3687 Perl_create_eval_scope(pTHX_ U32 flags)
3688 {
3689     PERL_CONTEXT *cx;
3690     const I32 gimme = GIMME_V;
3691
3692     ENTER;
3693     SAVETMPS;
3694
3695     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3696     PUSHEVAL(cx, 0, 0);
3697
3698     PL_in_eval = EVAL_INEVAL;
3699     if (flags & G_KEEPERR)
3700         PL_in_eval |= EVAL_KEEPERR;
3701     else
3702         sv_setpvn(ERRSV,"",0);
3703     if (flags & G_FAKINGEVAL) {
3704         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3705     }
3706     return cx;
3707 }
3708
3709 PP(pp_entertry)
3710 {
3711     dVAR;
3712     PERL_CONTEXT * const cx = create_eval_scope(0);
3713     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3714     return DOCATCH(PL_op->op_next);
3715 }
3716
3717 PP(pp_leavetry)
3718 {
3719     dVAR; dSP;
3720     SV **newsp;
3721     PMOP *newpm;
3722     I32 gimme;
3723     register PERL_CONTEXT *cx;
3724     I32 optype;
3725
3726     POPBLOCK(cx,newpm);
3727     POPEVAL(cx);
3728     PERL_UNUSED_VAR(optype);
3729
3730     TAINT_NOT;
3731     if (gimme == G_VOID)
3732         SP = newsp;
3733     else if (gimme == G_SCALAR) {
3734         register SV **mark;
3735         MARK = newsp + 1;
3736         if (MARK <= SP) {
3737             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3738                 *MARK = TOPs;
3739             else
3740                 *MARK = sv_mortalcopy(TOPs);
3741         }
3742         else {
3743             MEXTEND(mark,0);
3744             *MARK = &PL_sv_undef;
3745         }
3746         SP = MARK;
3747     }
3748     else {
3749         /* in case LEAVE wipes old return values */
3750         register SV **mark;
3751         for (mark = newsp + 1; mark <= SP; mark++) {
3752             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3753                 *mark = sv_mortalcopy(*mark);
3754                 TAINT_NOT;      /* Each item is independent */
3755             }
3756         }
3757     }
3758     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3759
3760     LEAVE;
3761     sv_setpvn(ERRSV,"",0);
3762     RETURN;
3763 }
3764
3765 PP(pp_entergiven)
3766 {
3767     dVAR; dSP;
3768     register PERL_CONTEXT *cx;
3769     const I32 gimme = GIMME_V;
3770
3771     ENTER;
3772     SAVETMPS;
3773
3774     if (PL_op->op_targ == 0) {
3775         SV ** const defsv_p = &GvSV(PL_defgv);
3776         *defsv_p = newSVsv(POPs);
3777         SAVECLEARSV(*defsv_p);
3778     }
3779     else
3780         sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3781
3782     PUSHBLOCK(cx, CXt_GIVEN, SP);
3783     PUSHGIVEN(cx);
3784
3785     RETURN;
3786 }
3787
3788 PP(pp_leavegiven)
3789 {
3790     dVAR; dSP;
3791     register PERL_CONTEXT *cx;
3792     I32 gimme;
3793     SV **newsp;
3794     PMOP *newpm;
3795     PERL_UNUSED_CONTEXT;
3796
3797     POPBLOCK(cx,newpm);
3798     assert(CxTYPE(cx) == CXt_GIVEN);
3799
3800     SP = newsp;
3801     PUTBACK;
3802
3803     PL_curpm = newpm;   /* pop $1 et al */
3804
3805     LEAVE;
3806
3807     return NORMAL;
3808 }
3809
3810 /* Helper routines used by pp_smartmatch */
3811 STATIC PMOP *
3812 S_make_matcher(pTHX_ regexp *re)
3813 {
3814     dVAR;
3815     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3816     PM_SETRE(matcher, ReREFCNT_inc(re));
3817
3818     SAVEFREEOP((OP *) matcher);
3819     ENTER; SAVETMPS;
3820     SAVEOP();
3821     return matcher;
3822 }
3823
3824 STATIC bool
3825 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3826 {
3827     dVAR;
3828     dSP;
3829
3830     PL_op = (OP *) matcher;
3831     XPUSHs(sv);
3832     PUTBACK;
3833     (void) pp_match();
3834     SPAGAIN;
3835     return (SvTRUEx(POPs));
3836 }
3837
3838 STATIC void
3839 S_destroy_matcher(pTHX_ PMOP *matcher)
3840 {
3841     dVAR;
3842     PERL_UNUSED_ARG(matcher);
3843     FREETMPS;
3844     LEAVE;
3845 }
3846
3847 /* Do a smart match */
3848 PP(pp_smartmatch)
3849 {
3850     return do_smartmatch(NULL, NULL);
3851 }
3852
3853 /* This version of do_smartmatch() implements the
3854  * table of smart matches that is found in perlsyn.
3855  */
3856 STATIC OP *
3857 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3858 {
3859     dVAR;
3860     dSP;
3861
3862     SV *e = TOPs;       /* e is for 'expression' */
3863     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
3864     SV *This, *Other;   /* 'This' (and Other to match) to play with C++ */
3865     MAGIC *mg;
3866     regexp *this_regex, *other_regex;
3867
3868 #   define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3869
3870 #   define SM_REF(type) ( \
3871            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3872         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3873
3874 #   define SM_CV_NEP   /* Find a code ref without an empty prototype */ \
3875         ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV)              \
3876             && NOT_EMPTY_PROTO(This) && (Other = e))                    \
3877         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV)            \
3878             && NOT_EMPTY_PROTO(This) && (Other = d)))
3879
3880 #   define SM_REGEX ( \
3881            (SvROK(d) && SvMAGICAL(This = SvRV(d))                       \
3882         && (mg = mg_find(This, PERL_MAGIC_qr))                          \
3883         && (this_regex = (regexp *)mg->mg_obj)                          \
3884         && (Other = e))                                                 \
3885     ||                                                                  \
3886            (SvROK(e) && SvMAGICAL(This = SvRV(e))                       \
3887         && (mg = mg_find(This, PERL_MAGIC_qr))                          \
3888         && (this_regex = (regexp *)mg->mg_obj)                          \
3889         && (Other = d)) )
3890
3891
3892 #   define SM_OTHER_REF(type) \
3893         (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3894
3895 #   define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other))       \
3896         && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr))                   \
3897         && (other_regex = (regexp *)mg->mg_obj))
3898
3899
3900 #   define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3901         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3902
3903 #   define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3904         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3905
3906     tryAMAGICbinSET(smart, 0);
3907
3908     SP -= 2;    /* Pop the values */
3909
3910     /* Take care only to invoke mg_get() once for each argument.
3911      * Currently we do this by copying the SV if it's magical. */
3912     if (d) {
3913         if (SvGMAGICAL(d))
3914             d = sv_mortalcopy(d);
3915     }
3916     else
3917         d = &PL_sv_undef;
3918
3919     assert(e);
3920     if (SvGMAGICAL(e))
3921         e = sv_mortalcopy(e);
3922
3923     if (SM_CV_NEP) {
3924         I32 c;
3925
3926         if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3927         {
3928             if (This == SvRV(Other))
3929                 RETPUSHYES;
3930             else
3931                 RETPUSHNO;
3932         }
3933
3934         ENTER;
3935         SAVETMPS;
3936         PUSHMARK(SP);
3937         PUSHs(Other);
3938         PUTBACK;
3939         c = call_sv(This, G_SCALAR);
3940         SPAGAIN;
3941         if (c == 0)
3942             PUSHs(&PL_sv_no);
3943         else if (SvTEMP(TOPs))
3944             SvREFCNT_inc_void(TOPs);
3945         FREETMPS;
3946         LEAVE;
3947         RETURN;
3948     }
3949     else if (SM_REF(PVHV)) {
3950         if (SM_OTHER_REF(PVHV)) {
3951             /* Check that the key-sets are identical */
3952             HE *he;
3953             HV *other_hv = (HV *) SvRV(Other);
3954             bool tied = FALSE;
3955             bool other_tied = FALSE;
3956             U32 this_key_count  = 0,
3957                 other_key_count = 0;
3958
3959             /* Tied hashes don't know how many keys they have. */
3960             if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3961                 tied = TRUE;
3962             }
3963             else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3964                 HV * const temp = other_hv;
3965                 other_hv = (HV *) This;
3966                 This  = (SV *) temp;
3967                 tied = TRUE;
3968             }
3969             if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3970                 other_tied = TRUE;
3971
3972             if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
3973                 RETPUSHNO;
3974
3975             /* The hashes have the same number of keys, so it suffices
3976                to check that one is a subset of the other. */
3977             (void) hv_iterinit((HV *) This);
3978             while ( (he = hv_iternext((HV *) This)) ) {
3979                 I32 key_len;
3980                 char * const key = hv_iterkey(he, &key_len);
3981
3982                 ++ this_key_count;
3983
3984                 if(!hv_exists(other_hv, key, key_len)) {
3985                     (void) hv_iterinit((HV *) This);    /* reset iterator */
3986                     RETPUSHNO;
3987                 }
3988             }
3989
3990             if (other_tied) {
3991                 (void) hv_iterinit(other_hv);
3992                 while ( hv_iternext(other_hv) )
3993                     ++other_key_count;
3994             }
3995             else
3996                 other_key_count = HvUSEDKEYS(other_hv);
3997
3998             if (this_key_count != other_key_count)
3999                 RETPUSHNO;
4000             else
4001                 RETPUSHYES;
4002         }
4003         else if (SM_OTHER_REF(PVAV)) {
4004             AV * const other_av = (AV *) SvRV(Other);
4005             const I32 other_len = av_len(other_av) + 1;
4006             I32 i;
4007
4008             if (HvUSEDKEYS((HV *) This) != other_len)
4009                 RETPUSHNO;
4010
4011             for(i = 0; i < other_len; ++i) {
4012                 SV ** const svp = av_fetch(other_av, i, FALSE);
4013                 char *key;
4014                 STRLEN key_len;
4015
4016                 if (!svp)       /* ??? When can this happen? */
4017                     RETPUSHNO;
4018
4019                 key = SvPV(*svp, key_len);
4020                 if(!hv_exists((HV *) This, key, key_len))
4021                     RETPUSHNO;
4022             }
4023             RETPUSHYES;
4024         }
4025         else if (SM_OTHER_REGEX) {
4026             PMOP * const matcher = make_matcher(other_regex);
4027             HE *he;
4028
4029             (void) hv_iterinit((HV *) This);
4030             while ( (he = hv_iternext((HV *) This)) ) {
4031                 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4032                     (void) hv_iterinit((HV *) This);
4033                     destroy_matcher(matcher);
4034                     RETPUSHYES;
4035                 }
4036             }
4037             destroy_matcher(matcher);
4038             RETPUSHNO;
4039         }
4040         else {
4041             if (hv_exists_ent((HV *) This, Other, 0))
4042                 RETPUSHYES;
4043             else
4044                 RETPUSHNO;
4045         }
4046     }
4047     else if (SM_REF(PVAV)) {
4048         if (SM_OTHER_REF(PVAV)) {
4049             AV *other_av = (AV *) SvRV(Other);
4050             if (av_len((AV *) This) != av_len(other_av))
4051                 RETPUSHNO;
4052             else {
4053                 I32 i;
4054                 const I32 other_len = av_len(other_av);
4055
4056                 if (NULL == seen_this) {
4057                     seen_this = newHV();
4058                     (void) sv_2mortal((SV *) seen_this);
4059                 }
4060                 if (NULL == seen_other) {
4061                     seen_this = newHV();
4062                     (void) sv_2mortal((SV *) seen_other);
4063                 }
4064                 for(i = 0; i <= other_len; ++i) {
4065                     SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4066                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4067
4068                     if (!this_elem || !other_elem) {
4069                         if (this_elem || other_elem)
4070                             RETPUSHNO;
4071                     }
4072                     else if (SM_SEEN_THIS(*this_elem)
4073                          || SM_SEEN_OTHER(*other_elem))
4074                     {
4075                         if (*this_elem != *other_elem)
4076                             RETPUSHNO;
4077                     }
4078                     else {
4079                         (void)hv_store_ent(seen_this,
4080                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4081                                 &PL_sv_undef, 0);
4082                         (void)hv_store_ent(seen_other,
4083                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4084                                 &PL_sv_undef, 0);
4085                         PUSHs(*this_elem);
4086                         PUSHs(*other_elem);
4087
4088                         PUTBACK;
4089                         (void) do_smartmatch(seen_this, seen_other);
4090                         SPAGAIN;
4091
4092                         if (!SvTRUEx(POPs))
4093                             RETPUSHNO;
4094                     }
4095                 }
4096                 RETPUSHYES;
4097             }
4098         }
4099         else if (SM_OTHER_REGEX) {
4100             PMOP * const matcher = make_matcher(other_regex);
4101             const I32 this_len = av_len((AV *) This);
4102             I32 i;
4103
4104             for(i = 0; i <= this_len; ++i) {
4105                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4106                 if (svp && matcher_matches_sv(matcher, *svp)) {
4107                     destroy_matcher(matcher);
4108                     RETPUSHYES;
4109                 }
4110             }
4111             destroy_matcher(matcher);
4112             RETPUSHNO;
4113         }
4114         else if (SvIOK(Other) || SvNOK(Other)) {
4115             I32 i;
4116
4117             for(i = 0; i <= AvFILL((AV *) This); ++i) {
4118                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4119                 if (!svp)
4120                     continue;
4121
4122                 PUSHs(Other);
4123                 PUSHs(*svp);
4124                 PUTBACK;
4125                 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4126                     (void) pp_i_eq();
4127                 else
4128                     (void) pp_eq();
4129                 SPAGAIN;
4130                 if (SvTRUEx(POPs))
4131                     RETPUSHYES;
4132             }
4133             RETPUSHNO;
4134         }
4135         else if (SvPOK(Other)) {
4136             const I32 this_len = av_len((AV *) This);
4137             I32 i;
4138
4139             for(i = 0; i <= this_len; ++i) {
4140                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4141                 if (!svp)
4142                     continue;
4143
4144                 PUSHs(Other);
4145                 PUSHs(*svp);
4146                 PUTBACK;
4147                 (void) pp_seq();
4148                 SPAGAIN;
4149                 if (SvTRUEx(POPs))
4150                     RETPUSHYES;
4151             }
4152             RETPUSHNO;
4153         }
4154     }
4155     else if (!SvOK(d) || !SvOK(e)) {
4156         if (!SvOK(d) && !SvOK(e))
4157             RETPUSHYES;
4158         else
4159             RETPUSHNO;
4160     }
4161     else if (SM_REGEX) {
4162         PMOP * const matcher = make_matcher(this_regex);
4163
4164         PUTBACK;
4165         PUSHs(matcher_matches_sv(matcher, Other)
4166             ? &PL_sv_yes
4167             : &PL_sv_no);
4168         destroy_matcher(matcher);
4169         RETURN;
4170     }
4171     else if (SM_REF(PVCV)) {
4172         I32 c;
4173         /* This must be a null-prototyped sub, because we
4174            already checked for the other kind. */
4175
4176         ENTER;
4177         SAVETMPS;
4178         PUSHMARK(SP);
4179         PUTBACK;
4180         c = call_sv(This, G_SCALAR);
4181         SPAGAIN;
4182         if (c == 0)
4183             PUSHs(&PL_sv_undef);
4184         else if (SvTEMP(TOPs))
4185             SvREFCNT_inc_void(TOPs);
4186
4187         if (SM_OTHER_REF(PVCV)) {
4188             /* This one has to be null-proto'd too.
4189                Call both of 'em, and compare the results */
4190             PUSHMARK(SP);
4191             c = call_sv(SvRV(Other), G_SCALAR);
4192             SPAGAIN;
4193             if (c == 0)
4194                 PUSHs(&PL_sv_undef);
4195             else if (SvTEMP(TOPs))
4196                 SvREFCNT_inc_void(TOPs);
4197             FREETMPS;
4198             LEAVE;
4199             PUTBACK;
4200             return pp_eq();
4201         }
4202
4203         FREETMPS;
4204         LEAVE;
4205         RETURN;
4206     }
4207     else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4208          ||   ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4209     {
4210         if (SvPOK(Other) && !looks_like_number(Other)) {
4211             /* String comparison */
4212             PUSHs(d); PUSHs(e);
4213             PUTBACK;
4214             return pp_seq();
4215         }
4216         /* Otherwise, numeric comparison */
4217         PUSHs(d); PUSHs(e);
4218         PUTBACK;
4219         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4220             (void) pp_i_eq();
4221         else
4222             (void) pp_eq();
4223         SPAGAIN;
4224         if (SvTRUEx(POPs))
4225             RETPUSHYES;
4226         else
4227             RETPUSHNO;
4228     }
4229
4230     /* As a last resort, use string comparison */
4231     PUSHs(d); PUSHs(e);
4232     PUTBACK;
4233     return pp_seq();
4234 }
4235
4236 PP(pp_enterwhen)
4237 {
4238     dVAR; dSP;
4239     register PERL_CONTEXT *cx;
4240     const I32 gimme = GIMME_V;
4241
4242     /* This is essentially an optimization: if the match
4243        fails, we don't want to push a context and then
4244        pop it again right away, so we skip straight
4245        to the op that follows the leavewhen.
4246     */
4247     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4248         return cLOGOP->op_other->op_next;
4249
4250     ENTER;
4251     SAVETMPS;
4252
4253     PUSHBLOCK(cx, CXt_WHEN, SP);
4254     PUSHWHEN(cx);
4255
4256     RETURN;
4257 }
4258
4259 PP(pp_leavewhen)
4260 {
4261     dVAR; dSP;
4262     register PERL_CONTEXT *cx;
4263     I32 gimme;
4264     SV **newsp;
4265     PMOP *newpm;
4266
4267     POPBLOCK(cx,newpm);
4268     assert(CxTYPE(cx) == CXt_WHEN);
4269
4270     SP = newsp;
4271     PUTBACK;
4272
4273     PL_curpm = newpm;   /* pop $1 et al */
4274
4275     LEAVE;
4276     return NORMAL;
4277 }
4278
4279 PP(pp_continue)
4280 {
4281     dVAR;
4282     I32 cxix;
4283     register PERL_CONTEXT *cx;
4284     I32 inner;
4285
4286     cxix = dopoptowhen(cxstack_ix);
4287     if (cxix < 0)
4288         DIE(aTHX_ "Can't \"continue\" outside a when block");
4289     if (cxix < cxstack_ix)
4290         dounwind(cxix);
4291
4292     /* clear off anything above the scope we're re-entering */
4293     inner = PL_scopestack_ix;
4294     TOPBLOCK(cx);
4295     if (PL_scopestack_ix < inner)
4296         leave_scope(PL_scopestack[PL_scopestack_ix]);
4297     PL_curcop = cx->blk_oldcop;
4298     return cx->blk_givwhen.leave_op;
4299 }
4300
4301 PP(pp_break)
4302 {
4303     dVAR;
4304     I32 cxix;
4305     register PERL_CONTEXT *cx;
4306     I32 inner;
4307
4308     cxix = dopoptogiven(cxstack_ix);
4309     if (cxix < 0) {
4310         if (PL_op->op_flags & OPf_SPECIAL)
4311             DIE(aTHX_ "Can't use when() outside a topicalizer");
4312         else
4313             DIE(aTHX_ "Can't \"break\" outside a given block");
4314     }
4315     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4316         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4317
4318     if (cxix < cxstack_ix)
4319         dounwind(cxix);
4320
4321     /* clear off anything above the scope we're re-entering */
4322     inner = PL_scopestack_ix;
4323     TOPBLOCK(cx);
4324     if (PL_scopestack_ix < inner)
4325         leave_scope(PL_scopestack[PL_scopestack_ix]);
4326     PL_curcop = cx->blk_oldcop;
4327
4328     if (CxFOREACH(cx))
4329         return CX_LOOP_NEXTOP_GET(cx);
4330     else
4331         return cx->blk_givwhen.leave_op;
4332 }
4333
4334 STATIC OP *
4335 S_doparseform(pTHX_ SV *sv)
4336 {
4337     STRLEN len;
4338     register char *s = SvPV_force(sv, len);
4339     register char * const send = s + len;
4340     register char *base = NULL;
4341     register I32 skipspaces = 0;
4342     bool noblank   = FALSE;
4343     bool repeat    = FALSE;
4344     bool postspace = FALSE;
4345     U32 *fops;
4346     register U32 *fpc;
4347     U32 *linepc = NULL;
4348     register I32 arg;
4349     bool ischop;
4350     bool unchopnum = FALSE;
4351     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4352
4353     if (len == 0)
4354         Perl_croak(aTHX_ "Null picture in formline");
4355
4356     /* estimate the buffer size needed */
4357     for (base = s; s <= send; s++) {
4358         if (*s == '\n' || *s == '@' || *s == '^')
4359             maxops += 10;
4360     }
4361     s = base;
4362     base = NULL;
4363
4364     Newx(fops, maxops, U32);
4365     fpc = fops;
4366
4367     if (s < send) {
4368         linepc = fpc;
4369         *fpc++ = FF_LINEMARK;
4370         noblank = repeat = FALSE;
4371         base = s;
4372     }
4373
4374     while (s <= send) {
4375         switch (*s++) {
4376         default:
4377             skipspaces = 0;
4378             continue;
4379
4380         case '~':
4381             if (*s == '~') {
4382                 repeat = TRUE;
4383                 *s = ' ';
4384             }
4385             noblank = TRUE;
4386             s[-1] = ' ';
4387             /* FALL THROUGH */
4388         case ' ': case '\t':
4389             skipspaces++;
4390             continue;
4391         case 0:
4392             if (s < send) {
4393                 skipspaces = 0;
4394                 continue;
4395             } /* else FALL THROUGH */
4396         case '\n':
4397             arg = s - base;
4398             skipspaces++;
4399             arg -= skipspaces;
4400             if (arg) {
4401                 if (postspace)
4402                     *fpc++ = FF_SPACE;
4403                 *fpc++ = FF_LITERAL;
4404                 *fpc++ = (U16)arg;
4405             }
4406             postspace = FALSE;
4407             if (s <= send)
4408                 skipspaces--;
4409             if (skipspaces) {
4410                 *fpc++ = FF_SKIP;
4411                 *fpc++ = (U16)skipspaces;
4412             }
4413             skipspaces = 0;
4414             if (s <= send)
4415                 *fpc++ = FF_NEWLINE;
4416             if (noblank) {
4417                 *fpc++ = FF_BLANK;
4418                 if (repeat)
4419                     arg = fpc - linepc + 1;
4420                 else
4421                     arg = 0;
4422                 *fpc++ = (U16)arg;
4423             }
4424             if (s < send) {
4425                 linepc = fpc;
4426                 *fpc++ = FF_LINEMARK;
4427                 noblank = repeat = FALSE;
4428                 base = s;
4429             }
4430             else
4431                 s++;
4432             continue;
4433
4434         case '@':
4435         case '^':
4436             ischop = s[-1] == '^';
4437
4438             if (postspace) {
4439                 *fpc++ = FF_SPACE;
4440                 postspace = FALSE;
4441             }
4442             arg = (s - base) - 1;
4443             if (arg) {
4444                 *fpc++ = FF_LITERAL;
4445                 *fpc++ = (U16)arg;
4446             }
4447
4448             base = s - 1;
4449             *fpc++ = FF_FETCH;
4450             if (*s == '*') {
4451                 s++;
4452                 *fpc++ = 2;  /* skip the @* or ^* */
4453                 if (ischop) {
4454                     *fpc++ = FF_LINESNGL;
4455                     *fpc++ = FF_CHOP;
4456                 } else
4457                     *fpc++ = FF_LINEGLOB;
4458             }
4459             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4460                 arg = ischop ? 512 : 0;
4461                 base = s - 1;
4462                 while (*s == '#')
4463                     s++;
4464                 if (*s == '.') {
4465                     const char * const f = ++s;
4466                     while (*s == '#')
4467                         s++;
4468                     arg |= 256 + (s - f);
4469                 }
4470                 *fpc++ = s - base;              /* fieldsize for FETCH */
4471                 *fpc++ = FF_DECIMAL;
4472                 *fpc++ = (U16)arg;
4473                 unchopnum |= ! ischop;
4474             }
4475             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4476                 arg = ischop ? 512 : 0;
4477                 base = s - 1;
4478                 s++;                                /* skip the '0' first */
4479                 while (*s == '#')
4480                     s++;
4481                 if (*s == '.') {
4482                     const char * const f = ++s;
4483                     while (*s == '#')
4484                         s++;
4485                     arg |= 256 + (s - f);
4486                 }
4487                 *fpc++ = s - base;                /* fieldsize for FETCH */
4488                 *fpc++ = FF_0DECIMAL;
4489                 *fpc++ = (U16)arg;
4490                 unchopnum |= ! ischop;
4491             }
4492             else {
4493                 I32 prespace = 0;
4494                 bool ismore = FALSE;
4495
4496                 if (*s == '>') {
4497                     while (*++s == '>') ;
4498                     prespace = FF_SPACE;
4499                 }
4500                 else if (*s == '|') {
4501                     while (*++s == '|') ;
4502                     prespace = FF_HALFSPACE;
4503                     postspace = TRUE;
4504                 }
4505                 else {
4506                     if (*s == '<')
4507                         while (*++s == '<') ;
4508                     postspace = TRUE;
4509                 }
4510                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4511                     s += 3;
4512                     ismore = TRUE;
4513                 }
4514                 *fpc++ = s - base;              /* fieldsize for FETCH */
4515
4516                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4517
4518                 if (prespace)
4519                     *fpc++ = (U16)prespace;
4520                 *fpc++ = FF_ITEM;
4521                 if (ismore)
4522                     *fpc++ = FF_MORE;
4523                 if (ischop)
4524                     *fpc++ = FF_CHOP;
4525             }
4526             base = s;
4527             skipspaces = 0;
4528             continue;
4529         }
4530     }
4531     *fpc++ = FF_END;
4532
4533     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4534     arg = fpc - fops;
4535     { /* need to jump to the next word */
4536         int z;
4537         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4538         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4539         s = SvPVX(sv) + SvCUR(sv) + z;
4540     }
4541     Copy(fops, s, arg, U32);
4542     Safefree(fops);
4543     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4544     SvCOMPILED_on(sv);
4545
4546     if (unchopnum && repeat)
4547         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4548     return 0;
4549 }
4550
4551
4552 STATIC bool
4553 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4554 {
4555     /* Can value be printed in fldsize chars, using %*.*f ? */
4556     NV pwr = 1;
4557     NV eps = 0.5;
4558     bool res = FALSE;
4559     int intsize = fldsize - (value < 0 ? 1 : 0);
4560
4561     if (frcsize & 256)
4562         intsize--;
4563     frcsize &= 255;
4564     intsize -= frcsize;
4565
4566     while (intsize--) pwr *= 10.0;
4567     while (frcsize--) eps /= 10.0;
4568
4569     if( value >= 0 ){
4570         if (value + eps >= pwr)
4571             res = TRUE;
4572     } else {
4573         if (value - eps <= -pwr)
4574             res = TRUE;
4575     }
4576     return res;
4577 }
4578
4579 static I32
4580 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4581 {
4582     dVAR;
4583     SV * const datasv = FILTER_DATA(idx);
4584     const int filter_has_file = IoLINES(datasv);
4585     SV * const filter_state = (SV *)IoTOP_GV(datasv);
4586     SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4587     int status = 0;
4588     SV *upstream;
4589     STRLEN got_len;
4590     const char *got_p = NULL;
4591     const char *prune_from = NULL;
4592     bool read_from_cache = FALSE;
4593     STRLEN umaxlen;
4594
4595     assert(maxlen >= 0);
4596     umaxlen = maxlen;
4597
4598     /* I was having segfault trouble under Linux 2.2.5 after a
4599        parse error occured.  (Had to hack around it with a test
4600        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4601        not sure where the trouble is yet.  XXX */
4602
4603     if (IoFMT_GV(datasv)) {
4604         SV *const cache = (SV *)IoFMT_GV(datasv);
4605         if (SvOK(cache)) {
4606             STRLEN cache_len;
4607             const char *cache_p = SvPV(cache, cache_len);
4608             STRLEN take = 0;
4609
4610             if (umaxlen) {
4611                 /* Running in block mode and we have some cached data already.
4612                  */
4613                 if (cache_len >= umaxlen) {
4614                     /* In fact, so much data we don't even need to call
4615                        filter_read.  */
4616                     take = umaxlen;
4617                 }
4618             } else {
4619                 const char *const first_nl =
4620                     (const char *)memchr(cache_p, '\n', cache_len);
4621                 if (first_nl) {
4622                     take = first_nl + 1 - cache_p;
4623                 }
4624             }
4625             if (take) {
4626                 sv_catpvn(buf_sv, cache_p, take);
4627                 sv_chop(cache, cache_p + take);
4628                 /* Definately not EOF  */
4629                 return 1;
4630             }
4631
4632             sv_catsv(buf_sv, cache);
4633             if (umaxlen) {
4634                 umaxlen -= cache_len;
4635             }
4636             SvOK_off(cache);
4637             read_from_cache = TRUE;
4638         }
4639     }
4640
4641     /* Filter API says that the filter appends to the contents of the buffer.
4642        Usually the buffer is "", so the details don't matter. But if it's not,
4643        then clearly what it contains is already filtered by this filter, so we
4644        don't want to pass it in a second time.
4645        I'm going to use a mortal in case the upstream filter croaks.  */
4646     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4647         ? sv_newmortal() : buf_sv;
4648     SvUPGRADE(upstream, SVt_PV);
4649
4650     if (filter_has_file) {
4651         status = FILTER_READ(idx+1, upstream, 0);
4652     }
4653
4654     if (filter_sub && status >= 0) {
4655         dSP;
4656         int count;
4657
4658         ENTER;
4659         SAVE_DEFSV;
4660         SAVETMPS;
4661         EXTEND(SP, 2);
4662
4663         DEFSV = upstream;
4664         PUSHMARK(SP);
4665         PUSHs(sv_2mortal(newSViv(0)));
4666         if (filter_state) {
4667             PUSHs(filter_state);
4668         }
4669         PUTBACK;
4670         count = call_sv(filter_sub, G_SCALAR);
4671         SPAGAIN;
4672
4673         if (count > 0) {
4674             SV *out = POPs;
4675             if (SvOK(out)) {
4676                 status = SvIV(out);
4677             }
4678         }
4679
4680         PUTBACK;
4681         FREETMPS;
4682         LEAVE;
4683     }
4684
4685     if(SvOK(upstream)) {
4686         got_p = SvPV(upstream, got_len);
4687         if (umaxlen) {
4688             if (got_len > umaxlen) {
4689                 prune_from = got_p + umaxlen;
4690             }
4691         } else {
4692             const char *const first_nl =
4693                 (const char *)memchr(got_p, '\n', got_len);
4694             if (first_nl && first_nl + 1 < got_p + got_len) {
4695                 /* There's a second line here... */
4696                 prune_from = first_nl + 1;
4697             }
4698         }
4699     }
4700     if (prune_from) {
4701         /* Oh. Too long. Stuff some in our cache.  */
4702         STRLEN cached_len = got_p + got_len - prune_from;
4703         SV *cache = (SV *)IoFMT_GV(datasv);
4704
4705         if (!cache) {
4706             IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4707         } else if (SvOK(cache)) {
4708             /* Cache should be empty.  */
4709             assert(!SvCUR(cache));
4710         }
4711
4712         sv_setpvn(cache, prune_from, cached_len);
4713         /* If you ask for block mode, you may well split UTF-8 characters.
4714            "If it breaks, you get to keep both parts"
4715            (Your code is broken if you  don't put them back together again
4716            before something notices.) */
4717         if (SvUTF8(upstream)) {
4718             SvUTF8_on(cache);
4719         }
4720         SvCUR_set(upstream, got_len - cached_len);
4721         /* Can't yet be EOF  */
4722         if (status == 0)
4723             status = 1;
4724     }
4725
4726     /* If they are at EOF but buf_sv has something in it, then they may never
4727        have touched the SV upstream, so it may be undefined.  If we naively
4728        concatenate it then we get a warning about use of uninitialised value.
4729     */
4730     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4731         sv_catsv(buf_sv, upstream);
4732     }
4733
4734     if (status <= 0) {
4735         IoLINES(datasv) = 0;
4736         SvREFCNT_dec(IoFMT_GV(datasv));
4737         if (filter_state) {
4738             SvREFCNT_dec(filter_state);
4739             IoTOP_GV(datasv) = NULL;
4740         }
4741         if (filter_sub) {
4742             SvREFCNT_dec(filter_sub);
4743             IoBOTTOM_GV(datasv) = NULL;
4744         }
4745         filter_del(S_run_user_filter);
4746     }
4747     if (status == 0 && read_from_cache) {
4748         /* If we read some data from the cache (and by getting here it implies
4749            that we emptied the cache) then we aren't yet at EOF, and mustn't
4750            report that to our caller.  */
4751         return 1;
4752     }
4753     return status;
4754 }
4755
4756 /* perhaps someone can come up with a better name for
4757    this?  it is not really "absolute", per se ... */
4758 static bool
4759 S_path_is_absolute(const char *name)
4760 {
4761     if (PERL_FILE_IS_ABSOLUTE(name)
4762 #ifdef MACOS_TRADITIONAL
4763         || (*name == ':')
4764 #else
4765         || (*name == '.' && (name[1] == '/' ||
4766                              (name[1] == '.' && name[2] == '/')))
4767 #endif
4768          )
4769     {
4770         return TRUE;
4771     }
4772     else
4773         return FALSE;
4774 }
4775
4776 /*
4777  * Local variables:
4778  * c-indentation-style: bsd
4779  * c-basic-offset: 4
4780  * indent-tabs-mode: t
4781  * End:
4782  *
4783  * ex: set ts=8 sts=4 sw=4 noet:
4784  */