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