view release on metacpan or  search on metacpan

lib/Affix.c  view on Meta::CPAN

        XSRETURN_UNDEF;
    }

    size_t offset = 0;
    bool found = false;
    for (size_t i = 0; i < type->meta.aggregate_info.num_members; ++i) {
        const infix_struct_member * m = &type->meta.aggregate_info.members[i];
        if (m->name && strEQ(m->name, member_name)) {
            offset = m->offset;
            found = true;
            break;
        }
    }
    infix_arena_destroy(arena);
    if (!found) {
        warn("Member '%s' not found in type '%s'", member_name, signature);
        XSRETURN_UNDEF;
    }
    ST(0) = sv_2mortal(newSVuv(offset));
    XSRETURN(1);
}

void _export_function(pTHX_ HV * _export, const char * what, const char * _tag) {
    SV ** tag = hv_fetch(_export, _tag, strlen(_tag), TRUE);
    if (tag && SvOK(*tag) && SvROK(*tag) && (SvTYPE(SvRV(*tag))) == SVt_PVAV)
        av_push((AV *)SvRV(*tag), newSVpv(what, 0));
    else {
        AV * av = newAV();
        av_push(av, newSVpv(what, 0));
        (void)hv_store(_export, _tag, strlen(_tag), newRV_noinc(MUTABLE_SV(av)), 0);
    }
}

void _affix_callback_handler_entry(infix_context_t * ctx, void * retval, void ** args) {
    Affix_Callback_Data * cb_data = (Affix_Callback_Data *)infix_reverse_get_user_data(ctx);
    if (!cb_data)
        return;

#ifdef MULTIPLICITY
#ifdef PERL_SET_CONTEXT
    PERL_SET_CONTEXT(cb_data->perl);
#endif
#endif

    dTHXa(cb_data->perl);
    dSP;
    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    size_t num_args = infix_reverse_get_num_args(ctx);

    for (size_t i = 0; i < num_args; ++i) {
        const infix_type * type = infix_reverse_get_arg_type(ctx, i);
        Affix_Pull puller = get_pull_handler(aTHX_ type);
        if (!puller)
            croak("Unsupported callback argument type");
        SV * arg_sv = newSV(0);
        puller(aTHX_ nullptr, arg_sv, type, args[i]);
        mXPUSHs(arg_sv);
    }
    PUTBACK;
    const infix_type * ret_type = infix_reverse_get_return_type(ctx);
    U32 call_flags = /* G_EVAL |*/ G_KEEPERR | ((ret_type->category == INFIX_TYPE_VOID) ? G_VOID : G_SCALAR);
    size_t count = call_sv(cb_data->coderef_rv, call_flags);
    if (SvTRUE(ERRSV)) {
        Perl_warn(aTHX_ "Perl callback died: %" SVf, ERRSV);
        sv_setsv(ERRSV, &PL_sv_undef);
        if (retval && !(call_flags & G_VOID))
            memset(retval, 0, infix_type_get_size(ret_type));
    }
    else if (call_flags & G_SCALAR) {
        SPAGAIN;
        SV * return_sv = (count == 1) ? POPs : &PL_sv_undef;
        sv2ptr(aTHX_ nullptr, return_sv, retval, ret_type);
        PUTBACK;
    }
    FREETMPS;
    LEAVE;
}

XS_INTERNAL(Affix_as_string) {
    dVAR;
    dXSARGS;
    if (items < 1)
        croak_xs_usage(cv, "$affix");
    {
        char * RETVAL;
        dXSTARG;
        Affix * affix;
        if (sv_derived_from(ST(0), "Affix")) {
            IV tmp = SvIV((SV *)SvRV(ST(0)));
            affix = INT2PTR(Affix *, tmp);
        }
        else
            croak("affix is not of type Affix");
        RETVAL = (char *)affix->infix->target_fn;
        sv_setpv(TARG, RETVAL);
        XSprePUSH;
        PUSHTARG;
    }
    XSRETURN(1);
};


XS_INTERNAL(Affix_END) {
    dXSARGS;
    dMY_CXT;
    PERL_UNUSED_VAR(items);
    if (MY_CXT.lib_registry) {
        hv_iterinit(MY_CXT.lib_registry);
        HE * he;
        while ((he = hv_iternext(MY_CXT.lib_registry))) {
            SV * entry_sv = HeVAL(he);
            LibRegistryEntry * entry = INT2PTR(LibRegistryEntry *, SvIV(entry_sv));
            if (entry) {
#if DEBUG > 0
                if (entry->ref_count > 0)
                    warn("Affix: library handle for '%s' has %d outstanding references at END.",
                         HeKEY(he),
                         (int)entry->ref_count);
#endif

                // Temp fix: Disable library unloading at process exit.
                //
                // Many modern C libraries (WebUI, Go runtimes, Audio libs) spawn background
                // threads that persist until the process dies. If we dlclose() the library
                // here, the code segment is unmapped. When the background thread wakes up
                // to do cleanup or work, it executes garbage memory and segfaults.
                //
                // Since the process is ending, the OS will reclaim file handles and memory
                // automatically. It's (in my opinion) safer to leak the handle than to crash the process.
#if defined(__linux__) || defined(__linux)
                // Leak the library handle but free our wrapper
                if (entry->lib)
                    infix_free(entry->lib);

lib/Affix.c  view on Meta::CPAN

            const char * name = infix_registry_iterator_get_name(&it);
            PUSHs(sv_2mortal(newSVpv(name, 0)));
        }
    }
    XSRETURN(count);
}

void _DumpHex(pTHX_ const void * addr, size_t len, const char * file, int line) {
    if (addr == nullptr) {
        printf("Dumping %lu bytes from null pointer %p at %s line %d\n", (unsigned long)len, addr, file, line);
        fflush(stdout);
        return;
    }
    fflush(stdout);
    int perLine = 16;
    if (perLine < 4 || perLine > 64)
        perLine = 16;
    size_t i;
    U8 * buff;
    Newxz(buff, perLine + 1, U8);
    const U8 * pc = (const U8 *)addr;
    printf("Dumping %lu bytes from %p at %s line %d\n", (unsigned long)len, addr, file, line);
    if (len == 0) {
        warn("ZERO LENGTH");
        return;
    }
    for (i = 0; i < len; i++) {
        if ((i % perLine) == 0) {
            if (i != 0)
                printf(" | %s\n", buff);
            printf("#  %03zu ", i);
        }
        printf(" %02x", pc[i]);
        if ((pc[i] < 0x20) || (pc[i] > 0x7e))
            buff[i % perLine] = '.';
        else
            buff[i % perLine] = pc[i];
        buff[(i % perLine) + 1] = '\0';
    }
    while ((i % perLine) != 0) {
        printf("   ");
        i++;
    }
    printf(" | %s\n", buff);
    safefree(buff);
    fflush(stdout);
}

void _DD(pTHX_ SV * scalar, const char * file, int line) {
    Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvs("Data::Printer"), nullptr, nullptr, nullptr);
    if (!get_cvs("Data::Printer::p", GV_NOADD_NOINIT | GV_NO_SVGMAGIC))
        return;
    fflush(stdout);
    dSP;
    int count;
    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    EXTEND(SP, 1);
    PUSHs(scalar);
    PUTBACK;
    count = call_pv("Data::Printer::p", G_SCALAR);
    SPAGAIN;
    if (count != 1) {
        warn("Big trouble\n");
        return;
    }
    STRLEN len;
    const char * s = SvPVx(POPs, len);
    printf("%s at %s line %d\n", s, file, line);
    fflush(stdout);
    PUTBACK;
    FREETMPS;
    LEAVE;
}

XS_INTERNAL(Affix_sv_dump) {
    dXSARGS;
    if (items != 1)
        croak_xs_usage(cv, "sv");
    sv_dump(ST(0));
    XSRETURN_EMPTY;
}

SV * _new_pointer_obj(pTHX_ Affix_Pin * pin) {
    SV * data_sv = newSV(0);
    sv_setiv(data_sv, PTR2IV(pin));
    SvUPGRADE(data_sv, SVt_PVMG);

    SV * rv = newRV_noinc(data_sv);

    // Bless into Affix::Pointer
    (void)sv_bless(rv, gv_stashpv("Affix::Pointer", GV_ADD));

    MAGIC * mg = sv_magicext(data_sv, nullptr, PERL_MAGIC_ext, &Affix_pin_vtbl, nullptr, 0);
    mg->mg_ptr = (char *)pin;

    return rv;
}

XS_INTERNAL(Affix_malloc) {
    dXSARGS;
    dMY_CXT;

    if (items < 1)
        croak_xs_usage(cv, "size");

    UV size = SvUV(ST(0));
    infix_type * type = nullptr;
    infix_arena_t * parse_arena = nullptr;

    const char * sig = "*void";

    if (infix_type_from_signature(&type, &parse_arena, sig, MY_CXT.registry) != INFIX_SUCCESS) {
        SV * err_sv = _format_parse_error(aTHX_ "for malloc", sig, infix_get_last_error());
        warn_sv(err_sv);
        if (parse_arena)
            infix_arena_destroy(parse_arena);
        XSRETURN_UNDEF;
    }

    if (size == 0) {
        infix_arena_destroy(parse_arena);
        warn("Cannot malloc a zero-sized type");
        XSRETURN_UNDEF;
    }

    void * ptr = safemalloc(size);
    Affix_Pin * pin;
    Newxz(pin, 1, Affix_Pin);
    pin->size = size;
    pin->pointer = ptr;