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