pp_ctl.c

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