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