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 OP *
2664 S_docatch(pTHX_ OP *o)
2665 {
2666     dVAR;
2667     int ret;
2668     OP * const oldop = PL_op;
2669     dJMPENV;
2670
2671 #ifdef DEBUGGING
2672     assert(CATCH_GET == TRUE);
2673 #endif
2674     PL_op = o;
2675
2676     JMPENV_PUSH(ret);
2677     switch (ret) {
2678     case 0:
2679         assert(cxstack_ix >= 0);
2680         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2681         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2682  redo_body:
2683         CALLRUNOPS(aTHX);
2684         break;
2685     case 3:
2686         /* die caught by an inner eval - continue inner loop */
2687
2688         /* NB XXX we rely on the old popped CxEVAL still being at the top
2689          * of the stack; the way die_where() currently works, this
2690          * assumption is valid. In theory The cur_top_env value should be
2691          * returned in another global, the way retop (aka PL_restartop)
2692          * is. */
2693         assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2694
2695         if (PL_restartop
2696             && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2697         {
2698             PL_op = PL_restartop;
2699             PL_restartop = 0;
2700             goto redo_body;
2701         }
2702         /* FALL THROUGH */
2703     default:
2704         JMPENV_POP;
2705         PL_op = oldop;
2706         JMPENV_JUMP(ret);
2707         /* NOTREACHED */
2708     }
2709     JMPENV_POP;
2710     PL_op = oldop;
2711     return NULL;
2712 }
2713
2714 OP *
2715 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2716 /* sv Text to convert to OP tree. */
2717 /* startop op_free() this to undo. */
2718 /* code Short string id of the caller. */
2719 {
2720     /* FIXME - how much of this code is common with pp_entereval?  */
2721     dVAR; dSP;                          /* Make POPBLOCK work. */
2722     PERL_CONTEXT *cx;
2723     SV **newsp;
2724     I32 gimme = G_VOID;
2725     I32 optype;
2726     OP dummy;
2727     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2728     char *tmpbuf = tbuf;
2729     char *safestr;
2730     int runtime;
2731     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
2732     STRLEN len;
2733
2734     ENTER;
2735     lex_start(sv, NULL, FALSE);
2736     SAVETMPS;
2737     /* switch to eval mode */
2738
2739     if (IN_PERL_COMPILETIME) {
2740         SAVECOPSTASH_FREE(&PL_compiling);
2741         CopSTASH_set(&PL_compiling, PL_curstash);
2742     }
2743     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2744         SV * const sv = sv_newmortal();
2745         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2746                        code, (unsigned long)++PL_evalseq,
2747                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2748         tmpbuf = SvPVX(sv);
2749         len = SvCUR(sv);
2750     }
2751     else
2752         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2753                           (unsigned long)++PL_evalseq);
2754     SAVECOPFILE_FREE(&PL_compiling);
2755     CopFILE_set(&PL_compiling, tmpbuf+2);
2756     SAVECOPLINE(&PL_compiling);
2757     CopLINE_set(&PL_compiling, 1);
2758     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2759        deleting the eval's FILEGV from the stash before gv_check() runs
2760        (i.e. before run-time proper). To work around the coredump that
2761        ensues, we always turn GvMULTI_on for any globals that were
2762        introduced within evals. See force_ident(). GSAR 96-10-12 */
2763     safestr = savepvn(tmpbuf, len);
2764     SAVEDELETE(PL_defstash, safestr, len);
2765     SAVEHINTS();
2766 #ifdef OP_IN_REGISTER
2767     PL_opsave = op;
2768 #else
2769     SAVEVPTR(PL_op);
2770 #endif
2771
2772     /* we get here either during compilation, or via pp_regcomp at runtime */
2773     runtime = IN_PERL_RUNTIME;
2774     if (runtime)
2775         runcv = find_runcv(NULL);
2776
2777     PL_op = &dummy;
2778     PL_op->op_type = OP_ENTEREVAL;
2779     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2780     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2781     PUSHEVAL(cx, 0, NULL);
2782
2783     if (runtime)
2784         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2785     else
2786         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2787     POPBLOCK(cx,PL_curpm);
2788     POPEVAL(cx);
2789
2790     (*startop)->op_type = OP_NULL;
2791     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2792     lex_end();
2793     /* XXX DAPM do this properly one year */
2794     *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2795     LEAVE;
2796     if (IN_PERL_COMPILETIME)
2797         CopHINTS_set(&PL_compiling, PL_hints);
2798 #ifdef OP_IN_REGISTER
2799     op = PL_opsave;
2800 #endif
2801     PERL_UNUSED_VAR(newsp);
2802     PERL_UNUSED_VAR(optype);
2803
2804     return PL_eval_start;
2805 }
2806
2807
2808 /*
2809 =for apidoc find_runcv
2810
2811 Locate the CV corresponding to the currently executing sub or eval.
2812 If db_seqp is non_null, skip CVs that are in the DB package and populate
2813 *db_seqp with the cop sequence number at the point that the DB:: code was
2814 entered. (allows debuggers to eval in the scope of the breakpoint rather
2815 than in the scope of the debugger itself).
2816
2817 =cut
2818 */
2819
2820 CV*
2821 Perl_find_runcv(pTHX_ U32 *db_seqp)
2822 {
2823     dVAR;
2824     PERL_SI      *si;
2825
2826     if (db_seqp)
2827         *db_seqp = PL_curcop->cop_seq;
2828     for (si = PL_curstackinfo; si; si = si->si_prev) {
2829         I32 ix;
2830         for (ix = si->si_cxix; ix >= 0; ix--) {
2831             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2832             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2833                 CV * const cv = cx->blk_sub.cv;
2834                 /* skip DB:: code */
2835                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2836                     *db_seqp = cx->blk_oldcop->cop_seq;
2837                     continue;
2838                 }
2839                 return cv;
2840             }
2841             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2842                 return PL_compcv;
2843         }
2844     }
2845     return PL_main_cv;
2846 }
2847
2848
2849 /* Compile a require/do, an eval '', or a /(?{...})/.
2850  * In the last case, startop is non-null, and contains the address of
2851  * a pointer that should be set to the just-compiled code.
2852  * outside is the lexically enclosing CV (if any) that invoked us.
2853  * Returns a bool indicating whether the compile was successful; if so,
2854  * PL_eval_start contains the first op of the compiled ocde; otherwise,
2855  * pushes undef (also croaks if startop != NULL).
2856  */
2857
2858 STATIC bool
2859 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2860 {
2861     dVAR; dSP;
2862     OP * const saveop = PL_op;
2863
2864     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2865                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2866                   : EVAL_INEVAL);
2867
2868     PUSHMARK(SP);
2869
2870     SAVESPTR(PL_compcv);
2871     PL_compcv = (CV*)newSV_type(SVt_PVCV);
2872     CvEVAL_on(PL_compcv);
2873     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2874     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2875
2876     CvOUTSIDE_SEQ(PL_compcv) = seq;
2877     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2878
2879     /* set up a scratch pad */
2880
2881     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2882     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2883
2884
2885     if (!PL_madskills)
2886         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
2887
2888     /* make sure we compile in the right package */
2889
2890     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2891         SAVESPTR(PL_curstash);
2892         PL_curstash = CopSTASH(PL_curcop);
2893     }
2894     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2895     SAVESPTR(PL_beginav);
2896     PL_beginav = newAV();
2897     SAVEFREESV(PL_beginav);
2898     SAVESPTR(PL_unitcheckav);
2899     PL_unitcheckav = newAV();
2900     SAVEFREESV(PL_unitcheckav);
2901
2902 #ifdef PERL_MAD
2903     SAVEBOOL(PL_madskills);
2904     PL_madskills = 0;
2905 #endif
2906
2907     /* try to compile it */
2908
2909     PL_eval_root = NULL;
2910     PL_curcop = &PL_compiling;
2911     CopARYBASE_set(PL_curcop, 0);
2912     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2913         PL_in_eval |= EVAL_KEEPERR;
2914     else
2915         sv_setpvn(ERRSV,"",0);
2916     if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2917         SV **newsp;                     /* Used by POPBLOCK. */
2918         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2919         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2920         const char *msg;
2921
2922         PL_op = saveop;
2923         if (PL_eval_root) {
2924             op_free(PL_eval_root);
2925             PL_eval_root = NULL;
2926         }
2927         SP = PL_stack_base + POPMARK;           /* pop original mark */
2928         if (!startop) {
2929             POPBLOCK(cx,PL_curpm);
2930             POPEVAL(cx);
2931         }
2932         lex_end();
2933         LEAVE;
2934
2935         msg = SvPVx_nolen_const(ERRSV);
2936         if (optype == OP_REQUIRE) {
2937             const SV * const nsv = cx->blk_eval.old_namesv;
2938             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
2939                           &PL_sv_undef, 0);
2940             Perl_croak(aTHX_ "%sCompilation failed in require",
2941                        *msg ? msg : "Unknown error\n");
2942         }
2943         else if (startop) {
2944             POPBLOCK(cx,PL_curpm);
2945             POPEVAL(cx);
2946             Perl_croak(aTHX_ "%sCompilation failed in regexp",
2947                        (*msg ? msg : "Unknown error\n"));
2948         }
2949         else {
2950             if (!*msg) {
2951                 sv_setpvs(ERRSV, "Compilation error");
2952             }
2953         }
2954         PERL_UNUSED_VAR(newsp);
2955         PUSHs(&PL_sv_undef);
2956         PUTBACK;
2957         return FALSE;
2958     }
2959     CopLINE_set(&PL_compiling, 0);
2960     if (startop) {
2961         *startop = PL_eval_root;
2962     } else
2963         SAVEFREEOP(PL_eval_root);
2964
2965     /* Set the context for this new optree.
2966      * If the last op is an OP_REQUIRE, force scalar context.
2967      * Otherwise, propagate the context from the eval(). */
2968     if (PL_eval_root->op_type == OP_LEAVEEVAL
2969             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
2970             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
2971             == OP_REQUIRE)
2972         scalar(PL_eval_root);
2973     else if (gimme & G_VOID)
2974         scalarvoid(PL_eval_root);
2975     else if (gimme & G_ARRAY)
2976         list(PL_eval_root);
2977     else
2978         scalar(PL_eval_root);
2979
2980     DEBUG_x(dump_eval());
2981
2982     /* Register with debugger: */
2983     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
2984         CV * const cv = get_cv("DB::postponed", FALSE);
2985         if (cv) {
2986             dSP;
2987             PUSHMARK(SP);
2988             XPUSHs((SV*)CopFILEGV(&PL_compiling));
2989             PUTBACK;
2990             call_sv((SV*)cv, G_DISCARD);
2991         }
2992     }
2993
2994     if (PL_unitcheckav)
2995         call_list(PL_scopestack_ix, PL_unitcheckav);
2996
2997     /* compiled okay, so do it */
2998
2999     CvDEPTH(PL_compcv) = 1;
3000     SP = PL_stack_base + POPMARK;               /* pop original mark */
3001     PL_op = saveop;                     /* The caller may need it. */
3002     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3003
3004     PUTBACK;
3005     return TRUE;
3006 }
3007
3008 STATIC PerlIO *
3009 S_check_type_and_open(pTHX_ const char *name)
3010 {
3011     Stat_t st;
3012     const int st_rc = PerlLIO_stat(name, &st);
3013
3014     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3015         return NULL;
3016     }
3017
3018     return PerlIO_open(name, PERL_SCRIPT_MODE);
3019 }
3020
3021 #ifndef PERL_DISABLE_PMC
3022 STATIC PerlIO *
3023 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3024 {
3025     PerlIO *fp;
3026
3027     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3028         SV *const pmcsv = newSV(namelen + 2);
3029         char *const pmc = SvPVX(pmcsv);
3030         Stat_t pmcstat;
3031
3032         memcpy(pmc, name, namelen);
3033         pmc[namelen] = 'c';
3034         pmc[namelen + 1] = '\0';
3035
3036         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3037             fp = check_type_and_open(name);
3038         }
3039         else {
3040             fp = check_type_and_open(pmc);
3041         }
3042         SvREFCNT_dec(pmcsv);
3043     }
3044     else {
3045         fp = check_type_and_open(name);
3046     }
3047     return fp;
3048 }
3049 #else
3050 #  define doopen_pm(name, namelen) check_type_and_open(name)
3051 #endif /* !PERL_DISABLE_PMC */
3052
3053 PP(pp_require)
3054 {
3055     dVAR; dSP;
3056     register PERL_CONTEXT *cx;
3057     SV *sv;
3058     const char *name;
3059     STRLEN len;
3060     char * unixname;
3061     STRLEN unixlen;
3062 #ifdef VMS
3063     int vms_unixname = 0;
3064 #endif
3065     const char *tryname = NULL;
3066     SV *namesv = NULL;
3067     const I32 gimme = GIMME_V;
3068     int filter_has_file = 0;
3069     PerlIO *tryrsfp = NULL;
3070     SV *filter_cache = NULL;
3071     SV *filter_state = NULL;
3072     SV *filter_sub = NULL;
3073     SV *hook_sv = NULL;
3074     SV *encoding;
3075     OP *op;
3076
3077     sv = POPs;
3078     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3079         if ( SvVOK(sv) && ckWARN(WARN_PORTABLE) ) {     /* require v5.6.1 */
3080             HV * hinthv = GvHV(PL_hintgv);
3081             SV ** ptr = NULL;
3082             if (hinthv) ptr = hv_fetchs(hinthv, "v_string", FALSE);
3083             if ( !(ptr && *ptr && SvIOK(*ptr) && SvIV(*ptr)) )
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         /* We do this only with use, not require. */
3137         if (PL_compcv &&
3138           /* If we request a version >= 5.6.0, then v-string are OK
3139              so set $^H{v_string} to suppress the v-string warning */
3140             vcmp(sv, sv_2mortal(upg_version(newSVnv(5.006), FALSE))) >= 0) {
3141           HV * hinthv = GvHV(PL_hintgv);
3142           if( hinthv ) {
3143               SV *hint = newSViv(1);
3144               (void)hv_stores(hinthv, "v_string", hint);
3145               /* This will call through to Perl_magic_sethint() which in turn
3146                  sets PL_hints correctly.  */
3147               SvSETMAGIC(hint);
3148           }
3149           /* If we request a version >= 5.9.5, load feature.pm with the
3150            * feature bundle that corresponds to the required version. */
3151           if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3152             SV *const importsv = vnormal(sv);
3153             *SvPVX_mutable(importsv) = ':';
3154             ENTER;
3155             Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3156             LEAVE;
3157           }
3158         }
3159
3160         RETPUSHYES;
3161     }
3162     name = SvPV_const(sv, len);
3163     if (!(name && len > 0 && *name))
3164         DIE(aTHX_ "Null filename used");
3165     TAINT_PROPER("require");
3166
3167
3168 #ifdef VMS
3169     /* The key in the %ENV hash is in the syntax of file passed as the argument
3170      * usually this is in UNIX format, but sometimes in VMS format, which
3171      * can result in a module being pulled in more than once.
3172      * To prevent this, the key must be stored in UNIX format if the VMS
3173      * name can be translated to UNIX.
3174      */
3175     if ((unixname = tounixspec(name, NULL)) != NULL) {
3176         unixlen = strlen(unixname);
3177         vms_unixname = 1;
3178     }
3179     else
3180 #endif
3181     {
3182         /* if not VMS or VMS name can not be translated to UNIX, pass it
3183          * through.
3184          */
3185         unixname = (char *) name;
3186         unixlen = len;
3187     }
3188     if (PL_op->op_type == OP_REQUIRE) {
3189         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3190                                           unixname, unixlen, 0);
3191         if ( svp ) {
3192             if (*svp != &PL_sv_undef)
3193                 RETPUSHYES;
3194             else
3195                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3196                             "Compilation failed in require", unixname);
3197         }
3198     }
3199
3200     /* prepare to compile file */
3201
3202     if (path_is_absolute(name)) {
3203         tryname = name;
3204         tryrsfp = doopen_pm(name, len);
3205     }
3206 #ifdef MACOS_TRADITIONAL
3207     if (!tryrsfp) {
3208         char newname[256];
3209
3210         MacPerl_CanonDir(name, newname, 1);
3211         if (path_is_absolute(newname)) {
3212             tryname = newname;
3213             tryrsfp = doopen_pm(newname, strlen(newname));
3214         }
3215     }
3216 #endif
3217     if (!tryrsfp) {
3218         AV * const ar = GvAVn(PL_incgv);
3219         I32 i;
3220 #ifdef VMS
3221         if (vms_unixname)
3222 #endif
3223         {
3224             namesv = newSV(0);
3225             sv_upgrade(namesv, SVt_PV);
3226             for (i = 0; i <= AvFILL(ar); i++) {
3227                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3228
3229                 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3230                     mg_get(dirsv);
3231                 if (SvROK(dirsv)) {
3232                     int count;
3233                     SV **svp;
3234                     SV *loader = dirsv;
3235
3236                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3237                         && !sv_isobject(loader))
3238                     {
3239                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3240                     }
3241
3242                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3243                                    PTR2UV(SvRV(dirsv)), name);
3244                     tryname = SvPVX_const(namesv);
3245                     tryrsfp = NULL;
3246
3247                     ENTER;
3248                     SAVETMPS;
3249                     EXTEND(SP, 2);
3250
3251                     PUSHMARK(SP);
3252                     PUSHs(dirsv);
3253                     PUSHs(sv);
3254                     PUTBACK;
3255                     if (sv_isobject(loader))
3256                         count = call_method("INC", G_ARRAY);
3257                     else
3258                         count = call_sv(loader, G_ARRAY);
3259                     SPAGAIN;
3260
3261                     /* Adjust file name if the hook has set an %INC entry */
3262                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3263                     if (svp)
3264                         tryname = SvPVX_const(*svp);
3265
3266                     if (count > 0) {
3267                         int i = 0;
3268                         SV *arg;
3269
3270                         SP -= count - 1;
3271                         arg = SP[i++];
3272
3273                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3274                             && !isGV_with_GP(SvRV(arg))) {
3275                             filter_cache = SvRV(arg);
3276                             SvREFCNT_inc_simple_void_NN(filter_cache);
3277
3278                             if (i < count) {
3279                                 arg = SP[i++];
3280                             }
3281                         }
3282
3283                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3284                             arg = SvRV(arg);
3285                         }
3286
3287                         if (SvTYPE(arg) == SVt_PVGV) {
3288                             IO * const io = GvIO((GV *)arg);
3289
3290                             ++filter_has_file;
3291
3292                             if (io) {
3293                                 tryrsfp = IoIFP(io);
3294                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3295                                     PerlIO_close(IoOFP(io));
3296                                 }
3297                                 IoIFP(io) = NULL;
3298                                 IoOFP(io) = NULL;
3299                             }
3300
3301                             if (i < count) {
3302                                 arg = SP[i++];
3303                             }
3304                         }
3305
3306                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3307                             filter_sub = arg;
3308                             SvREFCNT_inc_simple_void_NN(filter_sub);
3309
3310                             if (i < count) {
3311                                 filter_state = SP[i];
3312                                 SvREFCNT_inc_simple_void(filter_state);
3313                             }
3314                         }
3315
3316                         if (!tryrsfp && (filter_cache || filter_sub)) {
3317                             tryrsfp = PerlIO_open(BIT_BUCKET,
3318                                                   PERL_SCRIPT_MODE);
3319                         }
3320                         SP--;
3321                     }
3322
3323                     PUTBACK;
3324                     FREETMPS;
3325                     LEAVE;
3326
3327                     if (tryrsfp) {
3328                         hook_sv = dirsv;
3329                         break;
3330                     }
3331
3332                     filter_has_file = 0;
3333                     if (filter_cache) {
3334                         SvREFCNT_dec(filter_cache);
3335                         filter_cache = NULL;
3336                     }
3337                     if (filter_state) {
3338                         SvREFCNT_dec(filter_state);
3339                         filter_state = NULL;
3340                     }
3341                     if (filter_sub) {
3342                         SvREFCNT_dec(filter_sub);
3343                         filter_sub = NULL;
3344                     }
3345                 }
3346                 else {
3347                   if (!path_is_absolute(name)
3348 #ifdef MACOS_TRADITIONAL
3349                         /* We consider paths of the form :a:b ambiguous and interpret them first
3350                            as global then as local
3351                         */
3352                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3353 #endif
3354                   ) {
3355                     const char *dir;
3356                     STRLEN dirlen;
3357
3358                     if (SvOK(dirsv)) {
3359                         dir = SvPV_const(dirsv, dirlen);
3360                     } else {
3361                         dir = "";
3362                         dirlen = 0;
3363                     }
3364
3365 #ifdef MACOS_TRADITIONAL
3366                     char buf1[256];
3367                     char buf2[256];
3368
3369                     MacPerl_CanonDir(name, buf2, 1);
3370                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3371 #else
3372 #  ifdef VMS
3373                     char *unixdir;
3374                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3375                         continue;
3376                     sv_setpv(namesv, unixdir);
3377                     sv_catpv(namesv, unixname);
3378 #  else
3379 #    ifdef __SYMBIAN32__
3380                     if (PL_origfilename[0] &&
3381                         PL_origfilename[1] == ':' &&
3382                         !(dir[0] && dir[1] == ':'))
3383                         Perl_sv_setpvf(aTHX_ namesv,
3384                                        "%c:%s\\%s",
3385                                        PL_origfilename[0],
3386                                        dir, name);
3387                     else
3388                         Perl_sv_setpvf(aTHX_ namesv,
3389                                        "%s\\%s",
3390                                        dir, name);
3391 #    else
3392                     /* The equivalent of
3393                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3394                        but without the need to parse the format string, or
3395                        call strlen on either pointer, and with the correct
3396                        allocation up front.  */
3397                     {
3398                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3399
3400                         memcpy(tmp, dir, dirlen);
3401                         tmp +=dirlen;
3402                         *tmp++ = '/';
3403                         /* name came from an SV, so it will have a '\0' at the
3404                            end that we can copy as part of this memcpy().  */
3405                         memcpy(tmp, name, len + 1);
3406
3407                         SvCUR_set(namesv, dirlen + len + 1);
3408
3409                         /* Don't even actually have to turn SvPOK_on() as we
3410                            access it directly with SvPVX() below.  */
3411                     }
3412 #    endif
3413 #  endif
3414 #endif
3415                     TAINT_PROPER("require");
3416                     tryname = SvPVX_const(namesv);
3417                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3418                     if (tryrsfp) {
3419                         if (tryname[0] == '.' && tryname[1] == '/')
3420                             tryname += 2;
3421                         break;
3422                     }
3423                     else if (errno == EMFILE)
3424                         /* no point in trying other paths if out of handles */
3425                         break;
3426                   }
3427                 }
3428             }
3429         }
3430     }
3431     SAVECOPFILE_FREE(&PL_compiling);
3432     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3433     SvREFCNT_dec(namesv);
3434     if (!tryrsfp) {
3435         if (PL_op->op_type == OP_REQUIRE) {
3436             const char *msgstr = name;
3437             if(errno == EMFILE) {
3438                 SV * const msg
3439                     = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
3440                                                Strerror(errno)));
3441                 msgstr = SvPV_nolen_const(msg);
3442             } else {
3443                 if (namesv) {                   /* did we lookup @INC? */
3444                     AV * const ar = GvAVn(PL_incgv);
3445                     I32 i;
3446                     SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3447                         "%s in @INC%s%s (@INC contains:",
3448                         msgstr,
3449                         (instr(msgstr, ".h ")
3450                          ? " (change .h to .ph maybe?)" : ""),
3451                         (instr(msgstr, ".ph ")
3452                          ? " (did you run h2ph?)" : "")
3453                                                               ));
3454
3455                     for (i = 0; i <= AvFILL(ar); i++) {
3456                         sv_catpvs(msg, " ");
3457                         sv_catsv(msg, *av_fetch(ar, i, TRUE));
3458                     }
3459                     sv_catpvs(msg, ")");
3460                     msgstr = SvPV_nolen_const(msg);
3461                 }
3462             }
3463             DIE(aTHX_ "Can't locate %s", msgstr);
3464         }
3465
3466         RETPUSHUNDEF;
3467     }
3468     else
3469         SETERRNO(0, SS_NORMAL);
3470
3471     /* Assume success here to prevent recursive requirement. */
3472     /* name is never assigned to again, so len is still strlen(name)  */
3473     /* Check whether a hook in @INC has already filled %INC */
3474     if (!hook_sv) {
3475         (void)hv_store(GvHVn(PL_incgv),
3476                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3477     } else {
3478         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3479         if (!svp)
3480             (void)hv_store(GvHVn(PL_incgv),
3481                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3482     }
3483
3484     ENTER;
3485     SAVETMPS;
3486     lex_start(NULL, tryrsfp, TRUE);
3487
3488     SAVEHINTS();
3489     PL_hints = 0;
3490     SAVECOMPILEWARNINGS();
3491     if (PL_dowarn & G_WARN_ALL_ON)
3492         PL_compiling.cop_warnings = pWARN_ALL ;
3493     else if (PL_dowarn & G_WARN_ALL_OFF)
3494         PL_compiling.cop_warnings = pWARN_NONE ;
3495     else
3496         PL_compiling.cop_warnings = pWARN_STD ;
3497
3498     if (filter_sub || filter_cache) {
3499         SV * const datasv = filter_add(S_run_user_filter, NULL);
3500         IoLINES(datasv) = filter_has_file;
3501         IoTOP_GV(datasv) = (GV *)filter_state;
3502         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3503         IoFMT_GV(datasv) = (GV *)filter_cache;
3504     }
3505
3506     /* switch to eval mode */
3507     PUSHBLOCK(cx, CXt_EVAL, SP);
3508     PUSHEVAL(cx, name, NULL);
3509     cx->blk_eval.retop = PL_op->op_next;
3510
3511     SAVECOPLINE(&PL_compiling);
3512     CopLINE_set(&PL_compiling, 0);
3513
3514     PUTBACK;
3515
3516     /* Store and reset encoding. */
3517     encoding = PL_encoding;
3518     PL_encoding = NULL;
3519
3520     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3521         op = DOCATCH(PL_eval_start);
3522     else
3523         op = PL_op->op_next;
3524
3525     /* Restore encoding. */
3526     PL_encoding = encoding;
3527
3528     return op;
3529 }
3530
3531 PP(pp_entereval)
3532 {
3533     dVAR; dSP;
3534     register PERL_CONTEXT *cx;
3535     SV *sv;
3536     const I32 gimme = GIMME_V;
3537     const I32 was = PL_sub_generation;
3538     char tbuf[TYPE_DIGITS(long) + 12];
3539     char *tmpbuf = tbuf;
3540     char *safestr;
3541     STRLEN len;
3542     bool ok;
3543     CV* runcv;
3544     U32 seq;
3545     HV *saved_hh = NULL;
3546     const char * const fakestr = "_<(eval )";
3547     const int fakelen = 9 + 1;
3548
3549     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3550         saved_hh = (HV*) SvREFCNT_inc(POPs);
3551     }
3552     sv = POPs;
3553
3554     TAINT_IF(SvTAINTED(sv));
3555     TAINT_PROPER("eval");
3556
3557     ENTER;
3558     lex_start(sv, NULL, FALSE);
3559     SAVETMPS;
3560
3561     /* switch to eval mode */
3562
3563     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3564         SV * const temp_sv = sv_newmortal();
3565         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3566                        (unsigned long)++PL_evalseq,
3567                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3568         tmpbuf = SvPVX(temp_sv);
3569         len = SvCUR(temp_sv);
3570     }
3571     else
3572         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3573     SAVECOPFILE_FREE(&PL_compiling);
3574     CopFILE_set(&PL_compiling, tmpbuf+2);
3575     SAVECOPLINE(&PL_compiling);
3576     CopLINE_set(&PL_compiling, 1);
3577     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3578        deleting the eval's FILEGV from the stash before gv_check() runs
3579        (i.e. before run-time proper). To work around the coredump that
3580        ensues, we always turn GvMULTI_on for any globals that were
3581        introduced within evals. See force_ident(). GSAR 96-10-12 */
3582     safestr = savepvn(tmpbuf, len);
3583     SAVEDELETE(PL_defstash, safestr, len);
3584     SAVEHINTS();
3585     PL_hints = PL_op->op_targ;
3586     if (saved_hh)
3587         GvHV(PL_hintgv) = saved_hh;
3588     SAVECOMPILEWARNINGS();
3589     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3590     if (PL_compiling.cop_hints_hash) {
3591         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3592     }
3593     PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3594     if (PL_compiling.cop_hints_hash) {
3595         HINTS_REFCNT_LOCK;
3596         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3597         HINTS_REFCNT_UNLOCK;
3598     }
3599     /* special case: an eval '' executed within the DB package gets lexically
3600      * placed in the first non-DB CV rather than the current CV - this
3601      * allows the debugger to execute code, find lexicals etc, in the
3602      * scope of the code being debugged. Passing &seq gets find_runcv
3603      * to do the dirty work for us */
3604     runcv = find_runcv(&seq);
3605
3606     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3607     PUSHEVAL(cx, 0, NULL);
3608     cx->blk_eval.retop = PL_op->op_next;
3609
3610     /* prepare to compile string */
3611
3612     if (PERLDB_LINE && PL_curstash != PL_debstash)
3613         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3614     PUTBACK;
3615     ok = doeval(gimme, NULL, runcv, seq);
3616     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3617         && ok) {
3618         /* Copy in anything fake and short. */
3619         my_strlcpy(safestr, fakestr, fakelen);
3620     }
3621     return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3622 }
3623
3624 PP(pp_leaveeval)
3625 {
3626     dVAR; dSP;
3627     register SV **mark;
3628     SV **newsp;
3629     PMOP *newpm;
3630     I32 gimme;
3631     register PERL_CONTEXT *cx;
3632     OP *retop;
3633     const U8 save_flags = PL_op -> op_flags;
3634     I32 optype;
3635
3636     POPBLOCK(cx,newpm);
3637     POPEVAL(cx);
3638     retop = cx->blk_eval.retop;
3639
3640     TAINT_NOT;
3641     if (gimme == G_VOID)
3642         MARK = newsp;
3643     else if (gimme == G_SCALAR) {
3644         MARK = newsp + 1;
3645         if (MARK <= SP) {
3646             if (SvFLAGS(TOPs) & SVs_TEMP)
3647                 *MARK = TOPs;
3648             else
3649                 *MARK = sv_mortalcopy(TOPs);
3650         }
3651         else {
3652             MEXTEND(mark,0);
3653             *MARK = &PL_sv_undef;
3654         }
3655         SP = MARK;
3656     }
3657     else {
3658         /* in case LEAVE wipes old return values */
3659         for (mark = newsp + 1; mark <= SP; mark++) {
3660             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3661                 *mark = sv_mortalcopy(*mark);
3662                 TAINT_NOT;      /* Each item is independent */
3663             }
3664         }
3665     }
3666     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3667
3668 #ifdef DEBUGGING
3669     assert(CvDEPTH(PL_compcv) == 1);
3670 #endif
3671     CvDEPTH(PL_compcv) = 0;
3672     lex_end();
3673
3674     if (optype == OP_REQUIRE &&
3675         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3676     {
3677         /* Unassume the success we assumed earlier. */
3678         SV * const nsv = cx->blk_eval.old_namesv;
3679         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3680         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3681         /* die_where() did LEAVE, or we won't be here */
3682     }
3683     else {
3684         LEAVE;
3685         if (!(save_flags & OPf_SPECIAL))
3686             sv_setpvn(ERRSV,"",0);
3687     }
3688
3689     RETURNOP(retop);
3690 }
3691
3692 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3693    close to the related Perl_create_eval_scope.  */
3694 void
3695 Perl_delete_eval_scope(pTHX)
3696 {
3697     SV **newsp;
3698     PMOP *newpm;
3699     I32 gimme;
3700     register PERL_CONTEXT *cx;
3701     I32 optype;
3702
3703     POPBLOCK(cx,newpm);
3704     POPEVAL(cx);
3705     PL_curpm = newpm;
3706     LEAVE;
3707     PERL_UNUSED_VAR(newsp);
3708     PERL_UNUSED_VAR(gimme);
3709     PERL_UNUSED_VAR(optype);
3710 }
3711
3712 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3713    also needed by Perl_fold_constants.  */
3714 PERL_CONTEXT *
3715 Perl_create_eval_scope(pTHX_ U32 flags)
3716 {
3717     PERL_CONTEXT *cx;
3718     const I32 gimme = GIMME_V;
3719
3720     ENTER;
3721     SAVETMPS;
3722
3723     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3724     PUSHEVAL(cx, 0, 0);
3725
3726     PL_in_eval = EVAL_INEVAL;
3727     if (flags & G_KEEPERR)
3728         PL_in_eval |= EVAL_KEEPERR;
3729     else
3730         sv_setpvn(ERRSV,"",0);
3731     if (flags & G_FAKINGEVAL) {
3732         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3733     }
3734     return cx;
3735 }
3736
3737 PP(pp_entertry)
3738 {
3739     dVAR;
3740     PERL_CONTEXT * const cx = create_eval_scope(0);
3741     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3742     return DOCATCH(PL_op->op_next);
3743 }
3744
3745 PP(pp_leavetry)
3746 {
3747     dVAR; dSP;
3748     SV **newsp;
3749     PMOP *newpm;
3750     I32 gimme;
3751     register PERL_CONTEXT *cx;
3752     I32 optype;
3753
3754     POPBLOCK(cx,newpm);
3755     POPEVAL(cx);
3756     PERL_UNUSED_VAR(optype);
3757
3758     TAINT_NOT;
3759     if (gimme == G_VOID)
3760         SP = newsp;
3761     else if (gimme == G_SCALAR) {
3762         register SV **mark;
3763         MARK = newsp + 1;
3764         if (MARK <= SP) {
3765             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3766                 *MARK = TOPs;
3767             else
3768                 *MARK = sv_mortalcopy(TOPs);
3769         }
3770         else {
3771             MEXTEND(mark,0);
3772             *MARK = &PL_sv_undef;
3773         }
3774         SP = MARK;
3775     }
3776     else {
3777         /* in case LEAVE wipes old return values */
3778         register SV **mark;
3779         for (mark = newsp + 1; mark <= SP; mark++) {
3780             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3781                 *mark = sv_mortalcopy(*mark);
3782                 TAINT_NOT;      /* Each item is independent */
3783             }
3784         }
3785     }
3786     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3787
3788     LEAVE;
3789     sv_setpvn(ERRSV,"",0);
3790     RETURN;
3791 }
3792
3793 PP(pp_entergiven)
3794 {
3795     dVAR; dSP;
3796     register PERL_CONTEXT *cx;
3797     const I32 gimme = GIMME_V;
3798
3799     ENTER;
3800     SAVETMPS;
3801
3802     if (PL_op->op_targ == 0) {
3803         SV ** const defsv_p = &GvSV(PL_defgv);
3804         *defsv_p = newSVsv(POPs);
3805         SAVECLEARSV(*defsv_p);
3806     }
3807     else
3808         sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3809
3810     PUSHBLOCK(cx, CXt_GIVEN, SP);
3811     PUSHGIVEN(cx);
3812
3813     RETURN;
3814 }
3815
3816 PP(pp_leavegiven)
3817 {
3818     dVAR; dSP;
3819     register PERL_CONTEXT *cx;
3820     I32 gimme;
3821     SV **newsp;
3822     PMOP *newpm;
3823     PERL_UNUSED_CONTEXT;
3824
3825     POPBLOCK(cx,newpm);
3826     assert(CxTYPE(cx) == CXt_GIVEN);
3827
3828     SP = newsp;
3829     PUTBACK;
3830
3831     PL_curpm = newpm;   /* pop $1 et al */
3832
3833     LEAVE;
3834
3835     return NORMAL;
3836 }
3837
3838 /* Helper routines used by pp_smartmatch */
3839 STATIC PMOP *
3840 S_make_matcher(pTHX_ regexp *re)
3841 {
3842     dVAR;
3843     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3844     PM_SETRE(matcher, ReREFCNT_inc(re));
3845
3846     SAVEFREEOP((OP *) matcher);
3847     ENTER; SAVETMPS;
3848     SAVEOP();
3849     return matcher;
3850 }
3851
3852 STATIC bool
3853 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3854 {
3855     dVAR;
3856     dSP;
3857
3858     PL_op = (OP *) matcher;
3859     XPUSHs(sv);
3860     PUTBACK;
3861     (void) pp_match();
3862     SPAGAIN;
3863     return (SvTRUEx(POPs));
3864 }
3865
3866 STATIC void
3867 S_destroy_matcher(pTHX_ PMOP *matcher)
3868 {
3869     dVAR;
3870     PERL_UNUSED_ARG(matcher);
3871     FREETMPS;
3872     LEAVE;
3873 }
3874
3875 /* Do a smart match */
3876 PP(pp_smartmatch)
3877 {
3878     return do_smartmatch(NULL, NULL);
3879 }
3880
3881 /* This version of do_smartmatch() implements the
3882  * table of smart matches that is found in perlsyn.
3883  */
3884 STATIC OP *
3885 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3886 {
3887     dVAR;
3888     dSP;
3889
3890     SV *e = TOPs;       /* e is for 'expression' */
3891     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
3892     SV *This, *Other;   /* 'This' (and Other to match) to play with C++ */
3893     MAGIC *mg;
3894     regexp *this_regex, *other_regex;
3895
3896 #   define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3897
3898 #   define SM_REF(type) ( \
3899            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3900         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3901
3902 #   define SM_CV_NEP   /* Find a code ref without an empty prototype */ \
3903         ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV)              \
3904             && NOT_EMPTY_PROTO(This) && (Other = e))                    \
3905         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV)            \
3906             && NOT_EMPTY_PROTO(This) && (Other = d)))
3907
3908 #   define SM_REGEX ( \
3909            (SvROK(d) && SvMAGICAL(This = SvRV(d))                       \
3910         && (mg = mg_find(This, PERL_MAGIC_qr))                          \
3911         && (this_regex = (regexp *)mg->mg_obj)                          \
3912         && (Other = e))                                                 \
3913     ||                                                                  \
3914            (SvROK(e) && SvMAGICAL(This = SvRV(e))                       \
3915         && (mg = mg_find(This, PERL_MAGIC_qr))                          \
3916         && (this_regex = (regexp *)mg->mg_obj)                          \
3917         && (Other = d)) )
3918
3919
3920 #   define SM_OTHER_REF(type) \
3921         (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3922
3923 #   define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other))       \
3924         && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr))                   \
3925         && (other_regex = (regexp *)mg->mg_obj))
3926
3927
3928 #   define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3929         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3930
3931 #   define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3932         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3933
3934     tryAMAGICbinSET(smart, 0);
3935
3936     SP -= 2;    /* Pop the values */
3937
3938     /* Take care only to invoke mg_get() once for each argument.
3939      * Currently we do this by copying the SV if it's magical. */
3940     if (d) {
3941         if (SvGMAGICAL(d))
3942             d = sv_mortalcopy(d);
3943     }
3944     else
3945         d = &PL_sv_undef;
3946
3947     assert(e);
3948     if (SvGMAGICAL(e))
3949         e = sv_mortalcopy(e);
3950
3951     if (SM_CV_NEP) {
3952         I32 c;
3953
3954         if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3955         {
3956             if (This == SvRV(Other))
3957                 RETPUSHYES;
3958             else
3959                 RETPUSHNO;
3960         }
3961
3962         ENTER;
3963         SAVETMPS;
3964         PUSHMARK(SP);
3965         PUSHs(Other);
3966         PUTBACK;
3967         c = call_sv(This, G_SCALAR);
3968         SPAGAIN;
3969         if (c == 0)
3970             PUSHs(&PL_sv_no);
3971         else if (SvTEMP(TOPs))
3972             SvREFCNT_inc_void(TOPs);
3973         FREETMPS;
3974         LEAVE;
3975         RETURN;
3976     }
3977     else if (SM_REF(PVHV)) {
3978         if (SM_OTHER_REF(PVHV)) {
3979             /* Check that the key-sets are identical */
3980             HE *he;
3981             HV *other_hv = (HV *) SvRV(Other);
3982             bool tied = FALSE;
3983             bool other_tied = FALSE;
3984             U32 this_key_count  = 0,
3985                 other_key_count = 0;
3986
3987             /* Tied hashes don't know how many keys they have. */
3988             if (SvTIED_mg(This, PERL_MAGIC_tied)) {
3989                 tied = TRUE;
3990             }
3991             else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
3992                 HV * const temp = other_hv;
3993                 other_hv = (HV *) This;
3994                 This  = (SV *) temp;
3995                 tied = TRUE;
3996             }
3997             if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
3998                 other_tied = TRUE;
3999
4000             if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4001                 RETPUSHNO;
4002
4003             /* The hashes have the same number of keys, so it suffices
4004                to check that one is a subset of the other. */
4005             (void) hv_iterinit((HV *) This);
4006             while ( (he = hv_iternext((HV *) This)) ) {
4007                 I32 key_len;
4008                 char * const key = hv_iterkey(he, &key_len);
4009
4010                 ++ this_key_count;
4011
4012                 if(!hv_exists(other_hv, key, key_len)) {
4013                     (void) hv_iterinit((HV *) This);    /* reset iterator */
4014                     RETPUSHNO;
4015                 }
4016             }
4017
4018             if (other_tied) {
4019                 (void) hv_iterinit(other_hv);
4020                 while ( hv_iternext(other_hv) )
4021                     ++other_key_count;
4022             }
4023             else
4024                 other_key_count = HvUSEDKEYS(other_hv);
4025
4026             if (this_key_count != other_key_count)
4027                 RETPUSHNO;
4028             else
4029                 RETPUSHYES;
4030         }
4031         else if (SM_OTHER_REF(PVAV)) {
4032             AV * const other_av = (AV *) SvRV(Other);
4033             const I32 other_len = av_len(other_av) + 1;
4034             I32 i;
4035
4036             for (i = 0; i < other_len; ++i) {
4037                 SV ** const svp = av_fetch(other_av, i, FALSE);
4038                 char *key;
4039                 STRLEN key_len;
4040
4041                 if (svp) {      /* ??? When can this not happen? */
4042                     key = SvPV(*svp, key_len);
4043                     if (hv_exists((HV *) This, key, key_len))
4044                         RETPUSHYES;
4045                 }
4046             }
4047             RETPUSHNO;
4048         }
4049         else if (SM_OTHER_REGEX) {
4050             PMOP * const matcher = make_matcher(other_regex);
4051             HE *he;
4052
4053             (void) hv_iterinit((HV *) This);
4054             while ( (he = hv_iternext((HV *) This)) ) {
4055                 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4056                     (void) hv_iterinit((HV *) This);
4057                     destroy_matcher(matcher);
4058                     RETPUSHYES;
4059                 }
4060             }
4061             destroy_matcher(matcher);
4062             RETPUSHNO;
4063         }
4064         else {
4065             if (hv_exists_ent((HV *) This, Other, 0))
4066                 RETPUSHYES;
4067             else
4068                 RETPUSHNO;
4069         }
4070     }
4071     else if (SM_REF(PVAV)) {
4072         if (SM_OTHER_REF(PVAV)) {
4073             AV *other_av = (AV *) SvRV(Other);
4074             if (av_len((AV *) This) != av_len(other_av))
4075                 RETPUSHNO;
4076             else {
4077                 I32 i;
4078                 const I32 other_len = av_len(other_av);
4079
4080                 if (NULL == seen_this) {
4081                     seen_this = newHV();
4082                     (void) sv_2mortal((SV *) seen_this);
4083                 }
4084                 if (NULL == seen_other) {
4085                     seen_this = newHV();
4086                     (void) sv_2mortal((SV *) seen_other);
4087                 }
4088                 for(i = 0; i <= other_len; ++i) {
4089                     SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4090                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4091
4092                     if (!this_elem || !other_elem) {
4093                         if (this_elem || other_elem)
4094                             RETPUSHNO;
4095                     }
4096                     else if (SM_SEEN_THIS(*this_elem)
4097                          || SM_SEEN_OTHER(*other_elem))
4098                     {
4099                         if (*this_elem != *other_elem)
4100                             RETPUSHNO;
4101                     }
4102                     else {
4103                         (void)hv_store_ent(seen_this,
4104                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4105                                 &PL_sv_undef, 0);
4106                         (void)hv_store_ent(seen_other,
4107                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4108                                 &PL_sv_undef, 0);
4109                         PUSHs(*this_elem);
4110                         PUSHs(*other_elem);
4111
4112                         PUTBACK;
4113                         (void) do_smartmatch(seen_this, seen_other);
4114                         SPAGAIN;
4115
4116                         if (!SvTRUEx(POPs))
4117                             RETPUSHNO;
4118                     }
4119                 }
4120                 RETPUSHYES;
4121             }
4122         }
4123         else if (SM_OTHER_REGEX) {
4124             PMOP * const matcher = make_matcher(other_regex);
4125             const I32 this_len = av_len((AV *) This);
4126             I32 i;
4127
4128             for(i = 0; i <= this_len; ++i) {
4129                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4130                 if (svp && matcher_matches_sv(matcher, *svp)) {
4131                     destroy_matcher(matcher);
4132                     RETPUSHYES;
4133                 }
4134             }
4135             destroy_matcher(matcher);
4136             RETPUSHNO;
4137         }
4138         else if (SvIOK(Other) || SvNOK(Other)) {
4139             I32 i;
4140
4141             for(i = 0; i <= AvFILL((AV *) This); ++i) {
4142                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4143                 if (!svp)
4144                     continue;
4145
4146                 PUSHs(Other);
4147                 PUSHs(*svp);
4148                 PUTBACK;
4149                 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4150                     (void) pp_i_eq();
4151                 else
4152                     (void) pp_eq();
4153                 SPAGAIN;
4154                 if (SvTRUEx(POPs))
4155                     RETPUSHYES;
4156             }
4157             RETPUSHNO;
4158         }
4159         else if (SvPOK(Other)) {
4160             const I32 this_len = av_len((AV *) This);
4161             I32 i;
4162
4163             for(i = 0; i <= this_len; ++i) {
4164                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4165                 if (!svp)
4166                     continue;
4167
4168                 PUSHs(Other);
4169                 PUSHs(*svp);
4170                 PUTBACK;
4171                 (void) pp_seq();
4172                 SPAGAIN;
4173                 if (SvTRUEx(POPs))
4174                     RETPUSHYES;
4175             }
4176             RETPUSHNO;
4177         }
4178     }
4179     else if (!SvOK(d) || !SvOK(e)) {
4180         if (!SvOK(d) && !SvOK(e))
4181             RETPUSHYES;
4182         else
4183             RETPUSHNO;
4184     }
4185     else if (SM_REGEX) {
4186         PMOP * const matcher = make_matcher(this_regex);
4187
4188         PUTBACK;
4189         PUSHs(matcher_matches_sv(matcher, Other)
4190             ? &PL_sv_yes
4191             : &PL_sv_no);
4192         destroy_matcher(matcher);
4193         RETURN;
4194     }
4195     else if (SM_REF(PVCV)) {
4196         I32 c;
4197         /* This must be a null-prototyped sub, because we
4198            already checked for the other kind. */
4199
4200         ENTER;
4201         SAVETMPS;
4202         PUSHMARK(SP);
4203         PUTBACK;
4204         c = call_sv(This, G_SCALAR);
4205         SPAGAIN;
4206         if (c == 0)
4207             PUSHs(&PL_sv_undef);
4208         else if (SvTEMP(TOPs))
4209             SvREFCNT_inc_void(TOPs);
4210
4211         if (SM_OTHER_REF(PVCV)) {
4212             /* This one has to be null-proto'd too.
4213                Call both of 'em, and compare the results */
4214             PUSHMARK(SP);
4215             c = call_sv(SvRV(Other), G_SCALAR);
4216             SPAGAIN;
4217             if (c == 0)
4218                 PUSHs(&PL_sv_undef);
4219             else if (SvTEMP(TOPs))
4220                 SvREFCNT_inc_void(TOPs);
4221             FREETMPS;
4222             LEAVE;
4223             PUTBACK;
4224             return pp_eq();
4225         }
4226
4227         FREETMPS;
4228         LEAVE;
4229         RETURN;
4230     }
4231     else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4232          ||   ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4233     {
4234         if (SvPOK(Other) && !looks_like_number(Other)) {
4235             /* String comparison */
4236             PUSHs(d); PUSHs(e);
4237             PUTBACK;
4238             return pp_seq();
4239         }
4240         /* Otherwise, numeric comparison */
4241         PUSHs(d); PUSHs(e);
4242         PUTBACK;
4243         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4244             (void) pp_i_eq();
4245         else
4246             (void) pp_eq();
4247         SPAGAIN;
4248         if (SvTRUEx(POPs))
4249             RETPUSHYES;
4250         else
4251             RETPUSHNO;
4252     }
4253
4254     /* As a last resort, use string comparison */
4255     PUSHs(d); PUSHs(e);
4256     PUTBACK;
4257     return pp_seq();
4258 }
4259
4260 PP(pp_enterwhen)
4261 {
4262     dVAR; dSP;
4263     register PERL_CONTEXT *cx;
4264     const I32 gimme = GIMME_V;
4265
4266     /* This is essentially an optimization: if the match
4267        fails, we don't want to push a context and then
4268        pop it again right away, so we skip straight
4269        to the op that follows the leavewhen.
4270     */
4271     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4272         return cLOGOP->op_other->op_next;
4273
4274     ENTER;
4275     SAVETMPS;
4276
4277     PUSHBLOCK(cx, CXt_WHEN, SP);
4278     PUSHWHEN(cx);
4279
4280     RETURN;
4281 }
4282
4283 PP(pp_leavewhen)
4284 {
4285     dVAR; dSP;
4286     register PERL_CONTEXT *cx;
4287     I32 gimme;
4288     SV **newsp;
4289     PMOP *newpm;
4290
4291     POPBLOCK(cx,newpm);
4292     assert(CxTYPE(cx) == CXt_WHEN);
4293
4294     SP = newsp;
4295     PUTBACK;
4296
4297     PL_curpm = newpm;   /* pop $1 et al */
4298
4299     LEAVE;
4300     return NORMAL;
4301 }
4302
4303 PP(pp_continue)
4304 {
4305     dVAR;
4306     I32 cxix;
4307     register PERL_CONTEXT *cx;
4308     I32 inner;
4309
4310     cxix = dopoptowhen(cxstack_ix);
4311     if (cxix < 0)
4312         DIE(aTHX_ "Can't \"continue\" outside a when block");
4313     if (cxix < cxstack_ix)
4314         dounwind(cxix);
4315
4316     /* clear off anything above the scope we're re-entering */
4317     inner = PL_scopestack_ix;
4318     TOPBLOCK(cx);
4319     if (PL_scopestack_ix < inner)
4320         leave_scope(PL_scopestack[PL_scopestack_ix]);
4321     PL_curcop = cx->blk_oldcop;
4322     return cx->blk_givwhen.leave_op;
4323 }
4324
4325 PP(pp_break)
4326 {
4327     dVAR;
4328     I32 cxix;
4329     register PERL_CONTEXT *cx;
4330     I32 inner;
4331
4332     cxix = dopoptogiven(cxstack_ix);
4333     if (cxix < 0) {
4334         if (PL_op->op_flags & OPf_SPECIAL)
4335             DIE(aTHX_ "Can't use when() outside a topicalizer");
4336         else
4337             DIE(aTHX_ "Can't \"break\" outside a given block");
4338     }
4339     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4340         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4341
4342     if (cxix < cxstack_ix)
4343         dounwind(cxix);
4344
4345     /* clear off anything above the scope we're re-entering */
4346     inner = PL_scopestack_ix;
4347     TOPBLOCK(cx);
4348     if (PL_scopestack_ix < inner)
4349         leave_scope(PL_scopestack[PL_scopestack_ix]);
4350     PL_curcop = cx->blk_oldcop;
4351
4352     if (CxFOREACH(cx))
4353         return CX_LOOP_NEXTOP_GET(cx);
4354     else
4355         return cx->blk_givwhen.leave_op;
4356 }
4357
4358 STATIC OP *
4359 S_doparseform(pTHX_ SV *sv)
4360 {
4361     STRLEN len;
4362     register char *s = SvPV_force(sv, len);
4363     register char * const send = s + len;
4364     register char *base = NULL;
4365     register I32 skipspaces = 0;
4366     bool noblank   = FALSE;
4367     bool repeat    = FALSE;
4368     bool postspace = FALSE;
4369     U32 *fops;
4370     register U32 *fpc;
4371     U32 *linepc = NULL;
4372     register I32 arg;
4373     bool ischop;
4374     bool unchopnum = FALSE;
4375     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4376
4377     if (len == 0)
4378         Perl_croak(aTHX_ "Null picture in formline");
4379
4380     /* estimate the buffer size needed */
4381     for (base = s; s <= send; s++) {
4382         if (*s == '\n' || *s == '@' || *s == '^')
4383             maxops += 10;
4384     }
4385     s = base;
4386     base = NULL;
4387
4388     Newx(fops, maxops, U32);
4389     fpc = fops;
4390
4391     if (s < send) {
4392         linepc = fpc;
4393         *fpc++ = FF_LINEMARK;
4394         noblank = repeat = FALSE;
4395         base = s;
4396     }
4397
4398     while (s <= send) {
4399         switch (*s++) {
4400         default:
4401             skipspaces = 0;
4402             continue;
4403
4404         case '~':
4405             if (*s == '~') {
4406                 repeat = TRUE;
4407                 *s = ' ';
4408             }
4409             noblank = TRUE;
4410             s[-1] = ' ';
4411             /* FALL THROUGH */
4412         case ' ': case '\t':
4413             skipspaces++;
4414             continue;
4415         case 0:
4416             if (s < send) {
4417                 skipspaces = 0;
4418                 continue;
4419             } /* else FALL THROUGH */
4420         case '\n':
4421             arg = s - base;
4422             skipspaces++;
4423             arg -= skipspaces;
4424             if (arg) {
4425                 if (postspace)
4426                     *fpc++ = FF_SPACE;
4427                 *fpc++ = FF_LITERAL;
4428                 *fpc++ = (U16)arg;
4429             }
4430             postspace = FALSE;
4431             if (s <= send)
4432                 skipspaces--;
4433             if (skipspaces) {
4434                 *fpc++ = FF_SKIP;
4435                 *fpc++ = (U16)skipspaces;
4436             }
4437             skipspaces = 0;
4438             if (s <= send)
4439                 *fpc++ = FF_NEWLINE;
4440             if (noblank) {
4441                 *fpc++ = FF_BLANK;
4442                 if (repeat)
4443                     arg = fpc - linepc + 1;
4444                 else
4445                     arg = 0;
4446                 *fpc++ = (U16)arg;
4447             }
4448             if (s < send) {
4449                 linepc = fpc;
4450                 *fpc++ = FF_LINEMARK;
4451                 noblank = repeat = FALSE;
4452                 base = s;
4453             }
4454             else
4455                 s++;
4456             continue;
4457
4458         case '@':
4459         case '^':
4460             ischop = s[-1] == '^';
4461
4462             if (postspace) {
4463                 *fpc++ = FF_SPACE;
4464                 postspace = FALSE;
4465             }
4466             arg = (s - base) - 1;
4467             if (arg) {
4468                 *fpc++ = FF_LITERAL;
4469                 *fpc++ = (U16)arg;
4470             }
4471
4472             base = s - 1;
4473             *fpc++ = FF_FETCH;
4474             if (*s == '*') {
4475                 s++;
4476                 *fpc++ = 2;  /* skip the @* or ^* */
4477                 if (ischop) {
4478                     *fpc++ = FF_LINESNGL;
4479                     *fpc++ = FF_CHOP;
4480                 } else
4481                     *fpc++ = FF_LINEGLOB;
4482             }
4483             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4484                 arg = ischop ? 512 : 0;
4485                 base = s - 1;
4486                 while (*s == '#')
4487                     s++;
4488                 if (*s == '.') {
4489                     const char * const f = ++s;
4490                     while (*s == '#')
4491                         s++;
4492                     arg |= 256 + (s - f);
4493                 }
4494                 *fpc++ = s - base;              /* fieldsize for FETCH */
4495                 *fpc++ = FF_DECIMAL;
4496                 *fpc++ = (U16)arg;
4497                 unchopnum |= ! ischop;
4498             }
4499             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4500                 arg = ischop ? 512 : 0;
4501                 base = s - 1;
4502                 s++;                                /* skip the '0' first */
4503                 while (*s == '#')
4504                     s++;
4505                 if (*s == '.') {
4506                     const char * const f = ++s;
4507                     while (*s == '#')
4508                         s++;
4509                     arg |= 256 + (s - f);
4510                 }
4511                 *fpc++ = s - base;                /* fieldsize for FETCH */
4512                 *fpc++ = FF_0DECIMAL;
4513                 *fpc++ = (U16)arg;
4514                 unchopnum |= ! ischop;
4515             }
4516             else {
4517                 I32 prespace = 0;
4518                 bool ismore = FALSE;
4519
4520                 if (*s == '>') {
4521                     while (*++s == '>') ;
4522                     prespace = FF_SPACE;
4523                 }
4524                 else if (*s == '|') {
4525                     while (*++s == '|') ;
4526                     prespace = FF_HALFSPACE;
4527                     postspace = TRUE;
4528                 }
4529                 else {
4530                     if (*s == '<')
4531                         while (*++s == '<') ;
4532                     postspace = TRUE;
4533                 }
4534                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4535                     s += 3;
4536                     ismore = TRUE;
4537                 }
4538                 *fpc++ = s - base;              /* fieldsize for FETCH */
4539
4540                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4541
4542                 if (prespace)
4543                     *fpc++ = (U16)prespace;
4544                 *fpc++ = FF_ITEM;
4545                 if (ismore)
4546                     *fpc++ = FF_MORE;
4547                 if (ischop)
4548                     *fpc++ = FF_CHOP;
4549             }
4550             base = s;
4551             skipspaces = 0;
4552             continue;
4553         }
4554     }
4555     *fpc++ = FF_END;
4556
4557     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4558     arg = fpc - fops;
4559     { /* need to jump to the next word */
4560         int z;
4561         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4562         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4563         s = SvPVX(sv) + SvCUR(sv) + z;
4564     }
4565     Copy(fops, s, arg, U32);
4566     Safefree(fops);
4567     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4568     SvCOMPILED_on(sv);
4569
4570     if (unchopnum && repeat)
4571         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4572     return 0;
4573 }
4574
4575
4576 STATIC bool
4577 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4578 {
4579     /* Can value be printed in fldsize chars, using %*.*f ? */
4580     NV pwr = 1;
4581     NV eps = 0.5;
4582     bool res = FALSE;
4583     int intsize = fldsize - (value < 0 ? 1 : 0);
4584
4585     if (frcsize & 256)
4586         intsize--;
4587     frcsize &= 255;
4588     intsize -= frcsize;
4589
4590     while (intsize--) pwr *= 10.0;
4591     while (frcsize--) eps /= 10.0;
4592
4593     if( value >= 0 ){
4594         if (value + eps >= pwr)
4595             res = TRUE;
4596     } else {
4597         if (value - eps <= -pwr)
4598             res = TRUE;
4599     }
4600     return res;
4601 }
4602
4603 static I32
4604 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4605 {
4606     dVAR;
4607     SV * const datasv = FILTER_DATA(idx);
4608     const int filter_has_file = IoLINES(datasv);
4609     SV * const filter_state = (SV *)IoTOP_GV(datasv);
4610     SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4611     int status = 0;
4612     SV *upstream;
4613     STRLEN got_len;
4614     const char *got_p = NULL;
4615     const char *prune_from = NULL;
4616     bool read_from_cache = FALSE;
4617     STRLEN umaxlen;
4618
4619     assert(maxlen >= 0);
4620     umaxlen = maxlen;
4621
4622     /* I was having segfault trouble under Linux 2.2.5 after a
4623        parse error occured.  (Had to hack around it with a test
4624        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4625        not sure where the trouble is yet.  XXX */
4626
4627     if (IoFMT_GV(datasv)) {
4628         SV *const cache = (SV *)IoFMT_GV(datasv);
4629         if (SvOK(cache)) {
4630             STRLEN cache_len;
4631             const char *cache_p = SvPV(cache, cache_len);
4632             STRLEN take = 0;
4633
4634             if (umaxlen) {
4635                 /* Running in block mode and we have some cached data already.
4636                  */
4637                 if (cache_len >= umaxlen) {
4638                     /* In fact, so much data we don't even need to call
4639                        filter_read.  */
4640                     take = umaxlen;
4641                 }
4642             } else {
4643                 const char *const first_nl =
4644                     (const char *)memchr(cache_p, '\n', cache_len);
4645                 if (first_nl) {
4646                     take = first_nl + 1 - cache_p;
4647                 }
4648             }
4649             if (take) {
4650                 sv_catpvn(buf_sv, cache_p, take);
4651                 sv_chop(cache, cache_p + take);
4652                 /* Definately not EOF  */
4653                 return 1;
4654             }
4655
4656             sv_catsv(buf_sv, cache);
4657             if (umaxlen) {
4658                 umaxlen -= cache_len;
4659             }
4660             SvOK_off(cache);
4661             read_from_cache = TRUE;
4662         }
4663     }
4664
4665     /* Filter API says that the filter appends to the contents of the buffer.
4666        Usually the buffer is "", so the details don't matter. But if it's not,
4667        then clearly what it contains is already filtered by this filter, so we
4668        don't want to pass it in a second time.
4669        I'm going to use a mortal in case the upstream filter croaks.  */
4670     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4671         ? sv_newmortal() : buf_sv;
4672     SvUPGRADE(upstream, SVt_PV);
4673
4674     if (filter_has_file) {
4675         status = FILTER_READ(idx+1, upstream, 0);
4676     }
4677
4678     if (filter_sub && status >= 0) {
4679         dSP;
4680         int count;
4681
4682         ENTER;
4683         SAVE_DEFSV;
4684         SAVETMPS;
4685         EXTEND(SP, 2);
4686
4687         DEFSV = upstream;
4688         PUSHMARK(SP);
4689         PUSHs(sv_2mortal(newSViv(0)));
4690         if (filter_state) {
4691             PUSHs(filter_state);
4692         }
4693         PUTBACK;
4694         count = call_sv(filter_sub, G_SCALAR);
4695         SPAGAIN;
4696
4697         if (count > 0) {
4698             SV *out = POPs;
4699             if (SvOK(out)) {
4700                 status = SvIV(out);
4701             }
4702         }
4703
4704         PUTBACK;
4705         FREETMPS;
4706         LEAVE;
4707     }
4708
4709     if(SvOK(upstream)) {
4710         got_p = SvPV(upstream, got_len);
4711         if (umaxlen) {
4712             if (got_len > umaxlen) {
4713                 prune_from = got_p + umaxlen;
4714             }
4715         } else {
4716             const char *const first_nl =
4717                 (const char *)memchr(got_p, '\n', got_len);
4718             if (first_nl && first_nl + 1 < got_p + got_len) {
4719                 /* There's a second line here... */
4720                 prune_from = first_nl + 1;
4721             }
4722         }
4723     }
4724     if (prune_from) {
4725         /* Oh. Too long. Stuff some in our cache.  */
4726         STRLEN cached_len = got_p + got_len - prune_from;
4727         SV *cache = (SV *)IoFMT_GV(datasv);
4728
4729         if (!cache) {
4730             IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4731         } else if (SvOK(cache)) {
4732             /* Cache should be empty.  */
4733             assert(!SvCUR(cache));
4734         }
4735
4736         sv_setpvn(cache, prune_from, cached_len);
4737         /* If you ask for block mode, you may well split UTF-8 characters.
4738            "If it breaks, you get to keep both parts"
4739            (Your code is broken if you  don't put them back together again
4740            before something notices.) */
4741         if (SvUTF8(upstream)) {
4742             SvUTF8_on(cache);
4743         }
4744         SvCUR_set(upstream, got_len - cached_len);
4745         /* Can't yet be EOF  */
4746         if (status == 0)
4747             status = 1;
4748     }
4749
4750     /* If they are at EOF but buf_sv has something in it, then they may never
4751        have touched the SV upstream, so it may be undefined.  If we naively
4752        concatenate it then we get a warning about use of uninitialised value.
4753     */
4754     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4755         sv_catsv(buf_sv, upstream);
4756     }
4757
4758     if (status <= 0) {
4759         IoLINES(datasv) = 0;
4760         SvREFCNT_dec(IoFMT_GV(datasv));
4761         if (filter_state) {
4762             SvREFCNT_dec(filter_state);
4763             IoTOP_GV(datasv) = NULL;
4764         }
4765         if (filter_sub) {
4766             SvREFCNT_dec(filter_sub);
4767             IoBOTTOM_GV(datasv) = NULL;
4768         }
4769         filter_del(S_run_user_filter);
4770     }
4771     if (status == 0 && read_from_cache) {
4772         /* If we read some data from the cache (and by getting here it implies
4773            that we emptied the cache) then we aren't yet at EOF, and mustn't
4774            report that to our caller.  */
4775         return 1;
4776     }
4777     return status;
4778 }
4779
4780 /* perhaps someone can come up with a better name for
4781    this?  it is not really "absolute", per se ... */
4782 static bool
4783 S_path_is_absolute(const char *name)
4784 {
4785     if (PERL_FILE_IS_ABSOLUTE(name)
4786 #ifdef MACOS_TRADITIONAL
4787         || (*name == ':')
4788 #else
4789         || (*name == '.' && (name[1] == '/' ||
4790                              (name[1] == '.' && name[2] == '/')))
4791 #endif
4792          )
4793     {
4794         return TRUE;
4795     }
4796     else
4797         return FALSE;
4798 }
4799
4800 /*
4801  * Local variables:
4802  * c-indentation-style: bsd
4803  * c-basic-offset: 4
4804  * indent-tabs-mode: t
4805  * End:
4806  *
4807  * ex: set ts=8 sts=4 sw=4 noet:
4808  */