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