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