pp_ctl.c

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