pp_ctl.c

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