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