pp_ctl.c

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