pp_ctl.c

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