File Coverage

src/xs/Stash.cc

Criterion	Covered	Total	%
statement	74	78	94.8
branch	60	110	54.5
condition			n/a
subroutine			n/a
pod			n/a
total	134	188	71.2

#include
#include
#include
#include

#ifndef PERL_VERSION_DECIMAL
#define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
#define PERL_DECIMAL_VERSION PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
#endif

using panda::string_view;
using panda::string;

namespace xs {

Stash::op_proxy& Stash::op_proxy::operator= (SV* val) {
    _throw();

    if (!val) {
        slot(Scalar());
        return *this;
    }

    if (SvROK(val)) val = SvRV(val);
    if (SvTYPE(val) == SVt_PVGV) return operator=((GV*)val);
    slot(val);
    return *this;
}

Stash::op_proxy& Stash::op_proxy::operator= (GV* val) {
    _throw();
    if (val) {
        SvREFCNT_inc_simple_void_NN(val);
        SvREFCNT_dec_NN(*ptr);
        *ptr = (SV*)val;
        Glob::operator=(val);
    } else { // it is not allowed to set NULL to hash element, so nullify all slots
        slot(Scalar());
        slot(Array());
        slot(Hash());
        slot(Sub());
    }
    return *this;
}

void Stash::_promote (GV* gv, const panda::string_view& key) const {
    if (!gv || SvTYPE(gv) == SVt_PVGV) return;

    // perl [5.22.0 - 5.26.0] had a bug: core dump while promoting !CvNAMED subs. workaround it by adding name by hand
    #if PERL_DECIMAL_VERSION < PERL_VERSION_DECIMAL(5,26,1) && PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(5,22,0)
        if (SvROK(gv)) {
            SV* val = SvRV(gv);
            if (SvTYPE(val) == SVt_PVCV && !CvNAMED((CV*)val)) { // core-dump in gv_init_pvn with non-named CV
                U32 hash;
                PERL_HASH(hash, key.data(), key.length());
                HEK* hek = share_hek(key.data(), key.length(), hash);
                ((XPVCV*)MUTABLE_PTR(SvANY(val)))->xcv_gv_u.xcv_hek = hek;
                CvNAMED_on((CV*)val);
                CvCVGV_RC_off((CV*)val);
                CvANON_off((CV*)val);
            }
        }
    #endif

    // promote SV to GV. Note that prior to perl 5.22, not any SV could be promoted, otherwise gv_init_pvn croaks()
    gv_init_pvn(gv, (HV*)sv, key.data(), key.length(), GV_ADDMULTI);  // GV_ADDMULTI suppresses 'used only once' warning
}

string Stash::path () const {
    auto pkg = name();
    int len = pkg.length();
    string ret(len+3);
    char* dst = ret.buf();
    const char* src = pkg.data();
    for (int i = 0; i < len; ++i) {
        if (*src == ':') {
            *dst = '/';
            ++src;
            ++i;
        }
        else *dst = *src;
        ++dst;
        ++src;
    }
    *dst++ = '.';
    *dst++ = 'p';
    *dst++ = 'm';
    ret.length(dst-ret.buf());
    return ret;
}

void Stash::mark_as_loaded (const Stash& source) const {
    if (!source) throw std::invalid_argument(string("can't register module '") + name() + "': source module doesn't exist");
    auto inc = Stash::root().hash("INC");
    auto realpath = inc.fetch(source.path());
    if (!realpath) throw std::invalid_argument(string("can't register module '") + name() + "': source module '" + source.name() + "' hasn't been registered");
    inc.store(path(), realpath);
}

void Stash::inherit (const Stash& parent) {
    auto ISA = array("ISA");
    if (!ISA) { // we must create @ISA via gv_fetchpvn_flags, because perl is written like a monkey's shit
        auto fqn = string(name()) + "::ISA";
        ISA = GvAV(gv_fetchpvn_flags(fqn.data(), fqn.length(), GV_ADD, SVt_PVAV));
    }
    av_push(ISA, Simple::shared(parent.name()).detach()); // can't use ISA.push() syntax, because @ISA is a magical array, otherwise MRO cache won't be cleared
}

void Stash::_throw_nomethod (const panda::string_view& name) const {
    throw std::invalid_argument(panda::string("can't locate method '") + name + "' via package '" + this->name() + "'");
}

bool Stash::isa (const panda::string_view& parent, U32 hash, int flags) const {
    if (name() == parent) return TRUE;

    const struct mro_meta*const meta = HvMROMETA((HV*)sv);
    HV *isa = meta->isa;

    if (!isa) {
        (void)mro_get_linear_isa((HV*)sv);
        isa = meta->isa;
    }

    if (hv_common(isa, NULL, parent.data(), parent.length(), flags, HV_FETCH_ISEXISTS, NULL, hash)) return TRUE;
    return FALSE;

}

Object Stash::bless () const {
    return Object(sv_bless(newRV_noinc(newSV_type(SVt_PVMG)), (HV*)sv), NONE);
}

Object Stash::bless (const Sv& what) const {
    if (SvROK(what)) return sv_bless(what, (HV*)sv);
    else return Object(sv_bless(newRV(what), (HV*)sv), NONE);
}

void Stash::add_const_sub (const panda::string_view& name, const Sv& _val) {
    auto val = _val;
    val.readonly(true);
    newCONSTSUB_flags((HV*)sv, name.data(), name.length(), 0, val.detach()); // detach because newCONSTSUB doesn't increment refcnt
}

}