p5helper.c

#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>

#define declare_cbs perl6_callbacks *cbs = (perl6_callbacks*)SvIV(*hv_fetchs(PL_modglobal, "Inline::Perl5 callbacks", 0));

static void xs_init (pTHX);
EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
EXTERN_C void boot_Socket (pTHX_ CV* cv);
int p5_is_live_wrapped_p6_object(PerlInterpreter *my_perl, SV *obj);

typedef struct {
    I32 key; /* to make sure it came from Inline */
    IV index;
    I32 is_wrapper;
} _perl6_magic;

typedef struct {
    I32 key; /* to make sure it came from Inline */
    IV index;
} _perl6_hash_magic;

typedef struct {
    SV *(*call_p6_method)(IV, char *, I32, SV *, SV **);
    SV *(*call_p6_package_method)(char *, char *, I32, SV *, SV **);
    SV *(*call_p6_callable)(IV, SV *, SV **);
    void (*free_p6_object)(IV);
    SV *(*hash_at_key)(IV, char *);
    SV *(*hash_assign_key)(IV, char *, SV *);
    SV *(*compile_to_end)(char *, char *, U32 *pos);
} perl6_callbacks;

#ifndef wrap_keyword_plugin
void Perl_wrap_keyword_plugin(pTHX_ Perl_keyword_plugin_t new_plugin, Perl_keyword_plugin_t *old_plugin_p)
{
    dVAR;

    PERL_UNUSED_CONTEXT;
    if (*old_plugin_p) return;
    if (!*old_plugin_p) {
        *old_plugin_p = PL_keyword_plugin;
        PL_keyword_plugin = new_plugin;
    }
}
#define wrap_keyword_plugin(new_plugin, old_plugin_p) Perl_wrap_keyword_plugin(aTHX_ new_plugin, old_plugin_p)
#endif

XS(p5_call_p6_method);
XS(p5_call_p6_extension_method);
XS(p5_destroy_p5_object);
XS(p5_call_p6_callable);
XS(p5_hash_at_key);
XS(p5_hash_assign_key);
XS(p5_load_module);
XS(p5_set_subname);

EXTERN_C void xs_init(pTHX) {
    char *file = __FILE__;
    /* DynaLoader is a special case */
    newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
    newXS("Perl6::Object::call_method", p5_call_p6_method, file);
    newXS("Perl6::Object::call_extension_method", p5_call_p6_extension_method, file);
    newXS("Perl6::Object::destroy", p5_destroy_p5_object, file);
    newXS("Perl6::Hash::FETCH", p5_hash_at_key, file);
    newXS("Perl6::Hash::STORE", p5_hash_assign_key, file);
    newXS("Perl6::Callable::call", p5_call_p6_callable, file);
    newXS("v6::load_module_impl", p5_load_module, file);
    newXS("v6::set_subname", p5_set_subname, file);
}

size_t p5_size_of_iv() {
    return IVSIZE;
}

#if NVSIZE > 8
#    define MYNVSIZE 8
#    define MYNV double
#else
#    define MYNVSIZE NVSIZE
#    define MYNV NV
#endif

size_t p5_size_of_nv() {
    return MYNVSIZE;
}

static int inited = 0;

static Perl_keyword_plugin_t next_keyword_plugin;
static int raku_keyword_plugin(pTHX_ char *keyword_ptr, STRLEN keyword_len, OP **op_ptr) {
    if (memEQs(keyword_ptr, keyword_len, "raku")) {
        // read the whole source file
        while (lex_next_chunk(0));

        // move into the raku block
        lex_read_space(0);
        lex_read_to(PL_parser->bufptr + 1);

        declare_cbs;
        U32 pos;
        char *bufptr = PL_parser->bufptr;
        STRLEN len;
        char *package_name = SvPV(PL_curstname, len);
        SV *code = cbs->compile_to_end(package_name, PL_parser->bufptr, &pos);
        lex_read_to(bufptr + pos + 1);

        *op_ptr = code ? newUNOP(OP_ENTERSUB, 0, newSVOP(OP_CONST, 0, code)) : NULL;

        return KEYWORD_PLUGIN_STMT;
    }
    else {
        return next_keyword_plugin(aTHX_ keyword_ptr, keyword_len, op_ptr);
    }
}

void p5_inline_perl6_xs_init(PerlInterpreter *my_perl) {
    char *file = __FILE__;
    newXS("Perl6::Object::call_method", p5_call_p6_method, file);
    newXS("Perl6::Object::call_extension_method", p5_call_p6_extension_method, file);
    newXS("Perl6::Hash::FETCH", p5_hash_at_key, file);
    newXS("Perl6::Hash::STORE", p5_hash_assign_key, file);
    newXS("Perl6::Callable::call", p5_call_p6_callable, file);
    newXS("v6::load_module_impl", p5_load_module, file);
    newXS("v6::set_subname", p5_set_subname, file);
    inited = 1;
}

void p5_init_callbacks(
    SV  *(*call_p6_method)(IV, char * , I32, SV *, SV **),
    SV  *(*call_p6_package_method)(char *, char * , I32, SV *, SV **),
    SV  *(*call_p6_callable)(IV, SV *, SV **),
    void (*free_p6_object)(IV),
    SV  *(*hash_at_key)(IV, char *),
    SV  *(*hash_assign_key)(IV, char *, SV *),
    SV  *(*compile_to_end)(char *, char *, U32 *)
) {
    perl6_callbacks *cbs = malloc(sizeof(perl6_callbacks));
    cbs->call_p6_method   = call_p6_method;
    cbs->call_p6_package_method = call_p6_package_method;
    cbs->call_p6_callable = call_p6_callable;
    cbs->free_p6_object   = free_p6_object;
    cbs->hash_at_key      = hash_at_key;
    cbs->hash_assign_key  = hash_assign_key;
    cbs->compile_to_end   = compile_to_end;
    hv_stores(PL_modglobal, "Inline::Perl5 callbacks", newSViv((IV)cbs));
}

static int interpreters = 0;
static int terminate = 0;

PerlInterpreter *p5_init_perl(
    int argc,
    char **argv,
    SV  *(*call_p6_method)(IV, char * , I32, SV *, SV **),
    SV  *(*call_p6_package_method)(char *, char * , I32, SV *, SV **),
    SV  *(*call_p6_callable)(IV, SV *, SV **),
    void (*free_p6_object)(IV),
    SV  *(*hash_at_key)(IV, char *),
    SV  *(*hash_assign_key)(IV, char *, SV *),
    SV  *(*compile_to_end)(char *, char *, U32 *)
) {
    if (inited) {
#ifndef MULTIPLICITY
        return NULL;
#endif
    }
    else {
        inited = 1;
        PERL_SYS_INIT(&argc, &argv);
    }

    interpreters++;

    PerlInterpreter *my_perl = perl_alloc();
    PERL_SET_CONTEXT(my_perl);
    PL_perl_destruct_level = 1;
    perl_construct( my_perl );
    perl_parse(my_perl, xs_init, argc, argv, NULL);
    PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
    perl_run(my_perl);

    p5_init_callbacks(
        call_p6_method,
        call_p6_package_method,
        call_p6_callable,
        free_p6_object,
        hash_at_key,
        hash_assign_key,
        compile_to_end
    );

    wrap_keyword_plugin(raku_keyword_plugin, &next_keyword_plugin);

    return my_perl;
}

void p5_destruct_perl(PerlInterpreter *my_perl) {
    PERL_SET_CONTEXT(my_perl);

    SV **cbs_entry = hv_fetchs(PL_modglobal, "Inline::Perl5 callbacks", 0);
    perl6_callbacks *cbs = NULL;
    if (cbs_entry) {
        cbs = (perl6_callbacks*)SvIV(*cbs_entry);
    }

    PL_perl_destruct_level = 1;

    POPSTACK_TO(PL_mainstack);
    dounwind(-1);
    LEAVE_SCOPE(0);

    perl_destruct(my_perl);
    perl_free(my_perl);

    if (cbs)
        free(cbs);

    if (--interpreters == 0 && terminate)
        PERL_SYS_TERM();
}

void p5_terminate() {
    terminate = 1;
}

U32 p5_SvIOK(PerlInterpreter *my_perl, SV* sv) {
    return SvIOK(sv);
}

U32 p5_SvNOK(PerlInterpreter *my_perl, SV* sv) {
    return SvNOK(sv);
}

U32 p5_SvPOK(PerlInterpreter *my_perl, SV* sv) {
    return SvPOK(sv);
}

U32 p5_sv_utf8(PerlInterpreter *my_perl, SV* sv) {
    PERL_SET_CONTEXT(my_perl);
    if (SvUTF8(sv)) { // UTF-8 flag set -> can use string as-is
        return 1;
    }
    else { // pure 7 bit ASCII is valid UTF-8 as well
        STRLEN len;
        char * const pv  = SvPV(sv, len);
        STRLEN i;
        for (i = 0; i < len; i++)
            if ((signed char) pv[i] < 0) // signed char!
                return 0;
        return 1;
    }
}

IV p5_sv_iv(PerlInterpreter *my_perl, SV* sv) {
    return SvIV(sv);
}

MYNV p5_sv_nv(PerlInterpreter *my_perl, SV* sv) {
    return (MYNV) SvNV(sv);
}

SV *p5_sv_rv(PerlInterpreter *my_perl, SV* sv) {
    return SvRV(sv);
}

int p5_is_object(PerlInterpreter *my_perl, SV* sv) {
    PERL_SET_CONTEXT(my_perl);
    return sv_isobject(sv);
}

int p5_is_sub_ref(PerlInterpreter *my_perl, SV* sv) {
    return (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV);
}

int p5_is_array(PerlInterpreter *my_perl, SV* sv) {
    return (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV);
}

int p5_is_hash(PerlInterpreter *my_perl, SV* sv) {
    MAGIC *mg;
    PERL_SET_CONTEXT(my_perl);
    return (
        (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV)
        ? ((mg = mg_find(SvRV(sv), PERL_MAGIC_tied)) && sv_isa(mg->mg_obj, "Perl6::Hash"))
            ? 2
            : 1
        : 0
    );
}

IV p5_unwrap_p6_hash(PerlInterpreter *my_perl, SV *obj) {
    PERL_SET_CONTEXT(my_perl);
    {
        MAGIC * const tie_mg = mg_find(SvRV(obj), PERL_MAGIC_tied);
        SV * const hash = tie_mg->mg_obj;
        SV * const p6hashobj = *(av_fetch((AV *) SvRV(hash), 0, 0));
        MAGIC * const mg = mg_find(SvRV(p6hashobj), '~');
        return ((_perl6_hash_magic*)(mg->mg_ptr))->index;
    }
}

int p5_is_scalar_ref(PerlInterpreter *my_perl, SV* sv) {
    return (SvROK(sv) && SvTYPE(SvRV(sv)) < SVt_PVAV);
}

int p5_is_undef(PerlInterpreter *my_perl, SV* sv) {
    return !SvOK(sv);
}

AV *p5_sv_to_av(PerlInterpreter *my_perl, SV* sv) {
    return (AV *) SvRV(sv);
}

AV *p5_sv_to_av_inc(PerlInterpreter *my_perl, SV* sv) {
    AV * const retval = (AV *) SvRV(sv);
    SvREFCNT_inc((SV *)retval);
    return retval;
}

HV *p5_sv_to_hv(PerlInterpreter *my_perl, SV* sv) {
    return (HV *) SvRV(sv);
}

char *p5_sv_to_char_star(PerlInterpreter *my_perl, SV *sv) {
    PERL_SET_CONTEXT(my_perl);
    {
        STRLEN len;
        char * const pv  = SvPV(sv, len);
        return pv;
    }
}

STRLEN p5_sv_to_buf(PerlInterpreter *my_perl, SV *sv, char **buf) {
    PERL_SET_CONTEXT(my_perl);
    {
        STRLEN len;
        *buf  = SvPV(sv, len);
        return len;
    }
}

SV *p5_sv_to_ref(PerlInterpreter *my_perl, SV *sv) {
    PERL_SET_CONTEXT(my_perl);
    return newRV_noinc(sv);
}

int p5_sv_refcnt(PerlInterpreter *my_perl, SV *sv) {
    PERL_SET_CONTEXT(my_perl);
    return SvREFCNT(sv);
}

void p5_sv_refcnt_dec(PerlInterpreter *my_perl, SV *sv) {
    PERL_SET_CONTEXT(my_perl);
    SvREFCNT_dec(sv);
}

void p5_sv_refcnt_inc(PerlInterpreter *my_perl, SV *sv) {
    SvREFCNT_inc(sv);
}

void p5_sv_destroy(PerlInterpreter *my_perl, SV *sv) {
    PERL_SET_CONTEXT(my_perl);
    if (!PL_in_clean_objs && !PL_in_clean_all)
        SvREFCNT_dec(sv); // don't bother during global deconstruction
}

void p5_sv_2mortal(PerlInterpreter *my_perl, SV *sv) {
    sv_2mortal(sv);
}

SV *p5_new_mortal_reference(PerlInterpreter *my_perl, SV *sv) {
    return newRV_inc(SvRV(sv));
}

SV *p5_int_to_sv(PerlInterpreter *my_perl, IV value) {
    PERL_SET_CONTEXT(my_perl);
    return newSViv(value);
}

SV *p5_float_to_sv(PerlInterpreter *my_perl, MYNV value) {
    PERL_SET_CONTEXT(my_perl);
    return newSVnv((NV)value);
}

SV *p5_str_to_sv(PerlInterpreter *my_perl, STRLEN len, char* value) {
    PERL_SET_CONTEXT(my_perl);
    return newSVpvn_flags(value, len, SVf_UTF8);
}

SV *p5_buf_to_sv(PerlInterpreter *my_perl, STRLEN len, char* value) {
    PERL_SET_CONTEXT(my_perl);
    return newSVpvn_flags(value, len, 0);
}

I32 p5_av_top_index(PerlInterpreter *my_perl, AV *av) {
    PERL_SET_CONTEXT(my_perl);
    return av_top_index(av);
}

SV *p5_av_fetch(PerlInterpreter *my_perl, AV *av, I32 key) {
    PERL_SET_CONTEXT(my_perl);
    {
        SV ** const item = av_fetch(av, key, 0);
        if (item)
            return *item;
        return NULL;
    }
}

void p5_av_store(PerlInterpreter *my_perl, AV *av, I32 key, SV *val) {
    PERL_SET_CONTEXT(my_perl);
    SvREFCNT_inc(val);
    if (av_store(av, key, val) == NULL)
        SvREFCNT_dec(val);
    return;
}

SV *p5_av_pop(PerlInterpreter *my_perl, AV *av) {
    PERL_SET_CONTEXT(my_perl);
    return av_pop(av);
}

void p5_av_push(PerlInterpreter *my_perl, AV *av, SV *sv) {
    PERL_SET_CONTEXT(my_perl);
    av_push(av, sv);
}

SV *p5_av_shift(PerlInterpreter *my_perl, AV *av) {
    PERL_SET_CONTEXT(my_perl);
    return av_shift(av);
}

void p5_av_unshift(PerlInterpreter *my_perl, AV *av, SV *sv) {
    PERL_SET_CONTEXT(my_perl);
    av_unshift(av, 1);
    SvREFCNT_inc(sv);
    if (av_store(av, 0, sv) == NULL)
        SvREFCNT_dec(sv);
}

void p5_av_delete(PerlInterpreter *my_perl, AV *av, I32 key) {
    PERL_SET_CONTEXT(my_perl);
    av_delete(av, key, G_DISCARD);
}

void p5_av_clear(PerlInterpreter *my_perl, AV *av) {
    PERL_SET_CONTEXT(my_perl);
    av_clear(av);
}

I32 p5_hv_iterinit(PerlInterpreter *my_perl, HV *hv) {
    PERL_SET_CONTEXT(my_perl);
    return hv_iterinit(hv);
}

HE *p5_hv_iternext(PerlInterpreter *my_perl, HV *hv) {
    PERL_SET_CONTEXT(my_perl);
    return hv_iternext(hv);
}

SV *p5_hv_iterkeysv(PerlInterpreter *my_perl, HE *entry) {
    PERL_SET_CONTEXT(my_perl);
    return hv_iterkeysv(entry);
}

SV *p5_hv_iterval(PerlInterpreter *my_perl, HV *hv, HE *entry) {
    PERL_SET_CONTEXT(my_perl);
    return hv_iterval(hv, entry);
}

SV *p5_hv_fetch(PerlInterpreter *my_perl, HV *hv, STRLEN len, const char *key) {
    PERL_SET_CONTEXT(my_perl);
    {
        SV ** const item = hv_fetch(hv, key, len, 0);
        if (item)
            return *item;
        return NULL;
    }
}

void p5_hv_store(PerlInterpreter *my_perl, HV *hv, const char *key, SV *val) {
    PERL_SET_CONTEXT(my_perl);
    hv_store(hv, key, strlen(key), val, 0);
}

int p5_hv_exists(PerlInterpreter *my_perl, HV *hv, STRLEN len, const char *key) {
    PERL_SET_CONTEXT(my_perl);
    return hv_exists(hv, key, len);
}

SV *p5_undef(PerlInterpreter *my_perl) {
    PERL_SET_CONTEXT(my_perl);
    return &PL_sv_undef;
}

HV *p5_newHV(PerlInterpreter *my_perl) {
    PERL_SET_CONTEXT(my_perl);
    return newHV();
}

AV *p5_newAV(PerlInterpreter *my_perl) {
    PERL_SET_CONTEXT(my_perl);
    return newAV();
}

SV *p5_newRV_noinc(PerlInterpreter *my_perl, SV *sv) {
    PERL_SET_CONTEXT(my_perl);
    return newRV_noinc(sv);
}

SV *p5_newRV_inc(PerlInterpreter *my_perl, SV *sv) {
    PERL_SET_CONTEXT(my_perl);
    return newRV_inc(sv);
}

const char *p5_sv_reftype(PerlInterpreter *my_perl, SV *sv) {
    PERL_SET_CONTEXT(my_perl);
    return sv_reftype(SvRV(sv), 1);
}

SV *p5_new_blessed_hashref(PerlInterpreter *my_perl, char *package) {
    PERL_SET_CONTEXT(my_perl);
    HV * obj = newHV();
    SV * const inst = newRV_noinc((SV*)obj);
    HV *stash = gv_stashpv(package, GV_ADD);
    (void)sv_bless(inst, stash);
    return inst;
}

I32 p5_get_type(PerlInterpreter *my_perl, SV *sv) {
    int is_hash;
    PERL_SET_CONTEXT(my_perl);
    if (p5_is_object(my_perl, sv)) {
        return 1;
    }
    else if (p5_is_sub_ref(my_perl, sv)) {
        return 2;
    }
    else if (p5_SvNOK(my_perl, sv)) {
        return 3;
    }
    else if (p5_SvIOK(my_perl, sv)) {
        return 4;
    }
    else if (p5_SvPOK(my_perl, sv)) {
        return 5;
    }
    else if (p5_is_array(my_perl, sv)) {
        return 6;
    }
    else if ((is_hash = p5_is_hash(my_perl, sv)) > 0) {
        return 6 + is_hash;
    }
    else if (p5_is_undef(my_perl, sv)) {
        return 9;
    }
    else if (p5_is_scalar_ref(my_perl, sv)) {
        return 10;
    }
    else if (SvTYPE(sv) == SVt_PVGV) {
        return 11;
    }
    else {
        return 0;
    }
}

SV *p5_get_global(PerlInterpreter *my_perl, const char* name) {
    PERL_SET_CONTEXT(my_perl);
    if (strlen(name) < 2)
        return NULL;

    if (name[0] == '$')
        return get_sv(&name[1], 0);

    if (name[0] == '@') {
        AV *av = get_av(&name[1], 0);
        return av ? sv_2mortal(newRV_inc((SV *)av)) : NULL;
    }

    if (name[0] == '%') {
        HV *hv = get_hv(&name[1], 0);
        return hv ? sv_2mortal(newRV_inc((SV *)hv)) : NULL;
    }

    return NULL;
}

void p5_set_global(PerlInterpreter *my_perl, const char* name, SV *value) {
    PERL_SET_CONTEXT(my_perl);
    if (strlen(name) < 2)
        return;

    if (name[0] == '$')
        SvSetSV(get_sv(&name[1], 0), value);

    else if (name[0] == '@')
        croak("Setting global array variable NYI");

    else if (name[0] == '%')
        croak("Setting global hash variable NYI");
}

I32 p5_compile_sv(PerlInterpreter *my_perl, SV *line, CV **cv, SV **stash) {
    PERL_SET_CONTEXT(my_perl);
    char *start = NULL;
    char start_orig;
    I32 floor;
    OP *op;

    ENTER;

    floor = start_subparse(FALSE, 0);

    if (PL_parser) {
        start = strstr(PL_parser->bufptr, SvPVX(line) + 1);
        start_orig = start[-1];
        start[-1] = '{';
        lex_read_to(start - 1);
    }
    else {
        lex_start(line, NULL, 0);
    }

    HV *new_stash = newHV();
    HV *cur_stash = PL_curstash;
    PL_curstash = new_stash;

    op = parse_block(0);

    PL_curstash = cur_stash;
    HE *he;
    while ((he = hv_iternext(new_stash))) {
        SV *key = hv_iterkeysv(he);
        SV *val = hv_iterval(new_stash, he);

        /* Put the entry into the actual target stash */
        hv_store_ent(PL_curstash, key, SvREFCNT_inc(val), HeHASH(he));

        if (   0 == strcmp(SvPV_nolen(key), "BEGIN")
            || 0 == strcmp(SvPV_nolen(key), "END")
            || 0 == strcmp(SvPV_nolen(key), "__ANON__"))
            hv_delete_ent(new_stash, key, G_DISCARD, HeHASH(he));
    }
    *stash = sv_2mortal(newRV_noinc((SV*)new_stash));

    I32 remainder = PL_parser->bufend - PL_parser->bufptr;

    *cv = newATTRSUB(floor, NULL, NULL, NULL, op);

    if (start)
        start[-1] = start_orig;
    else
        remainder -= 2; /* not sure why but it fixes things */

    LEAVE;

    return remainder;
}

void p5_runops(PerlInterpreter *my_perl, CV *cv) {
    dSP;
    ENTER;
    SAVETMPS;
    PUSHMARK(sp);
    call_sv((SV*)cv, G_DISCARD);
    SPAGAIN;
    FREETMPS;
    LEAVE;
}

SV *p5_eval_pv(PerlInterpreter *my_perl, const char* p, I32 croak_on_error) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        SV * retval;
        ENTER;
        SAVETMPS;
        PUSHMARK(SP);

        retval = eval_pv(p, croak_on_error);
        SvREFCNT_inc(retval);

        SPAGAIN;
        PUTBACK;
        FREETMPS;
        LEAVE;
        return retval;
    }
}

SV *p5_err_sv(PerlInterpreter *my_perl) {
    PERL_SET_CONTEXT(my_perl);
    return sv_mortalcopy(ERRSV);
}

void handle_p5_error(I32 *err) {
    SV *err_tmp = ERRSV;
    *err = SvTRUE(err_tmp);
}

void push_arguments(SV **sp, int len, SV *args[]) {
    int i;
    for (i = 0; i < len; i++) {
        if (args[i] != NULL) /* skip Nil which gets turned into NULL */
            XPUSHs(sv_2mortal(args[i]));
    }
    PUTBACK;
}

SV *pop_return_values(PerlInterpreter *my_perl, SV **sp, I32 count, I32 *type) {
    SV * retval = NULL;
    I32 i;

    if (count == 1) {
        retval = POPs;
        SvREFCNT_inc(retval);
        *type = p5_get_type(my_perl, retval);
    }
    else {
        if (count > 1) {
            retval = (SV *)newAV();
            av_extend((AV *)retval, count - 1);
        }

        for (i = count - 1; i >= 0; i--) {
            SV * const next = POPs;
            SvREFCNT_inc(next);

            if (av_store((AV *)retval, i, next) == NULL)
                SvREFCNT_dec(next); /* see perlguts Working with AVs */
        }
    }
    PUTBACK;

    return retval;
}

SV *p5_call_package_method(PerlInterpreter *my_perl, char *package, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        SV * retval = NULL;
        int flags = G_ARRAY | G_EVAL;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);
        XPUSHs(sv_2mortal(newSVpv(package, 0)));
        push_arguments(sp, len, args);

        *count = call_method(name, flags);
        SPAGAIN;

        handle_p5_error(err);

        retval = pop_return_values(my_perl, sp, *count, type);

        FREETMPS;
        LEAVE;

        return retval;
    }
}

GV *p5_look_up_package_method(PerlInterpreter *my_perl, char *module, char *name, I32 local) {
    PERL_SET_CONTEXT(my_perl);
    {
        HV * const pkg = gv_stashpvn(module, strlen(module), 0);
        GV * gv = gv_fetchmeth_pvn_autoload(pkg, name, strlen(name), -1, SVf_UTF8);
        if (gv && local) {
            GV * const super_gv = gv_fetchmeth_pvn_autoload(pkg, name, strlen(name), -1, SVf_UTF8 | GV_SUPER);
            if (super_gv && (super_gv == gv || GvCV(super_gv) == GvCV(gv)))
                gv = NULL;
        }
        if (gv && isGV(gv))
            return gv;
        return NULL;
    }
}

SV *p5_call_inherited_package_method(PerlInterpreter *my_perl, char *package, char *base_package, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        SV * retval = NULL;
        SV * package_sv = newSVpv(package, 0);
        HV * stash = gv_stashsv(package_sv, SVf_UTF8);
        int flags = G_ARRAY | G_EVAL;

        if (stash == NULL) {
            SvREFCNT_dec(package_sv);
            *type = -1; /* signal that a wrapper package needs to be created */
            return NULL;
        }

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);

        XPUSHs(sv_2mortal(package_sv));
        push_arguments(sp, len, args);

        GV * const gv = p5_look_up_package_method(my_perl, base_package, name, 0);
        SV * const rv = GvCV(gv) ? sv_2mortal(newRV_inc((SV*)GvCV(gv))) : (SV*)gv;
        *count = call_sv(rv, flags);

        SPAGAIN;

        handle_p5_error(err);

        retval = pop_return_values(my_perl, sp, *count, type);

        FREETMPS;
        LEAVE;

        return retval;
    }
}

char *p5_stash_name(PerlInterpreter *my_perl, SV *obj) {
    HV * const pkg = SvSTASH((SV*)SvRV(obj));
    return HvNAME(pkg);
}

SV *p5_call_gv(PerlInterpreter *my_perl, GV *gv, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        int i;
        SV * retval = NULL;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);

        if (len > 1) {
            XPUSHs(args[0]);
            for (i = 1; i < len; i++) {
                if (args[i] != NULL) /* skip Nil which gets turned into NULL */
                    XPUSHs(sv_2mortal(args[i]));
            }
        }
        else if (len > 0)
            if (args != NULL) /* skip Nil which gets turned into NULL */
                XPUSHs((SV*)args);

        PUTBACK;

        SV * const rv = GvCV(gv) ? sv_2mortal(newRV_inc((SV*)GvCV(gv))) : (SV*)gv;

        *count = call_sv(rv, G_ARRAY | G_EVAL);
        SPAGAIN;

        handle_p5_error(err);
        retval = pop_return_values(my_perl, sp, *count, type);

        FREETMPS;
        LEAVE;

        return retval;
    }
}

void reset_wrapped_object(PerlInterpreter *my_perl, SV *obj) {
    if (SvREFCNT(obj) == 1 && SvREFCNT(SvRV(obj)) == 1) {
        MAGIC * mg = mg_find(SvRV(obj), '~');
        _perl6_magic* const p6mg = (_perl6_magic*) mg->mg_ptr;
        SV **cbs_entry = hv_fetchs(PL_modglobal, "Inline::Perl5 callbacks", 0);
        if (cbs_entry) {
            perl6_callbacks *cbs = (perl6_callbacks*)SvIV(*cbs_entry);
            cbs->free_p6_object(p6mg->index);
        }
        p6mg->index = -1;
        SvREFCNT_inc(SvRV(obj)); // keep it from dying
    }
}

SV *p5_call_parent_gv(PerlInterpreter *my_perl, GV *gv, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        int i;
        SV * obj;
        SV * retval = NULL;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);

        obj = len > 1 ? args[0] : (SV*) args;

        if (len > 1) {
            XPUSHs(obj);
            for (i = 1; i < len; i++) {
                if (args[i] != NULL) /* skip Nil which gets turned into NULL */
                    XPUSHs(sv_2mortal(args[i]));
            }
        }
        else if (len > 0)
            if (args != NULL) /* skip Nil which gets turned into NULL */
                XPUSHs(obj);

        PUTBACK;

        SV * const rv = GvCV(gv) ? sv_2mortal(newRV((SV*)GvCV(gv))) : (SV*)gv; /* FIXME: can be done once */

        *count = call_sv(rv, G_ARRAY | G_EVAL);
        SPAGAIN;

        handle_p5_error(err);
        retval = pop_return_values(my_perl, sp, *count, type);

        reset_wrapped_object(my_perl, obj);
        SPAGAIN;
        SvREFCNT_dec(obj);

        FREETMPS;
        LEAVE;

        return retval;
    }
}

SV *p5_scalar_call_gv(PerlInterpreter *my_perl, GV *gv, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        int i;
        SV * retval = NULL;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);

        if (len > 1) {
            XPUSHs(args[0]);
            for (i = 1; i < len; i++) {
                if (args[i] != NULL) /* skip Nil which gets turned into NULL */
                    XPUSHs(sv_2mortal(args[i]));
            }
        }
        else if (len > 0)
            if (args != NULL) /* skip Nil which gets turned into NULL */
                XPUSHs((SV*)args);

        PUTBACK;

        SV * const rv = GvCV(gv) ? sv_2mortal(newRV_inc((SV*)GvCV(gv))) : (SV*)gv;

        *count = call_sv(rv, G_SCALAR | G_EVAL);
        SPAGAIN;

        handle_p5_error(err);
        retval = pop_return_values(my_perl, sp, *count, type);

        PUTBACK;
        FREETMPS;
        LEAVE;

        return retval;
    }
}

SV *p5_scalar_call_parent_gv(PerlInterpreter *my_perl, GV *gv, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        int i;
        SV * retval = NULL;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);

        if (len > 1) {
            XPUSHs(args[0]);
            for (i = 1; i < len; i++) {
                if (args[i] != NULL) /* skip Nil which gets turned into NULL */
                    XPUSHs(sv_2mortal(args[i]));
            }
        }
        else if (len > 0)
            if (args != NULL) /* skip Nil which gets turned into NULL */
                XPUSHs((SV*)args);

        PUTBACK;

        SV * const rv = GvCV(gv) ? sv_2mortal(newRV_inc((SV*)GvCV(gv))) : (SV*)gv;

        *count = call_sv(rv, G_SCALAR | G_EVAL);
        SPAGAIN;

        handle_p5_error(err);
        retval = pop_return_values(my_perl, sp, *count, type);

        FREETMPS;
        LEAVE;

        return retval;
    }
}

SV *p5_call_gv_two_args(PerlInterpreter *my_perl, GV *gv, SV *arg, SV *arg2, I32 *count, I32 *type, I32 *err) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        SV * retval = NULL;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);

        XPUSHs(sv_2mortal((SV*)arg));
        if (arg2 != NULL)
            XPUSHs(sv_2mortal((SV*)arg2));

        PUTBACK;

        SV * const rv = GvCV(gv) ? sv_2mortal(newRV_inc((SV*)GvCV(gv))) : (SV*)gv;

        *count = call_sv(rv, G_ARRAY | G_EVAL);
        SPAGAIN;

        handle_p5_error(err);
        retval = pop_return_values(my_perl, sp, *count, type);

        reset_wrapped_object(my_perl, arg);
        SPAGAIN;

        FREETMPS;
        LEAVE;

        return retval;
    }
}

SV *p5_scalar_call_gv_two_args(PerlInterpreter *my_perl, GV *gv, SV *arg, SV *arg2, I32 *count, I32 *type, I32 *err) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        SV * retval = NULL;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);

        XPUSHs(sv_2mortal((SV*)arg));
        if (arg2 != NULL)
            XPUSHs(sv_2mortal((SV*)arg2));

        PUTBACK;

        SV * const rv = GvCV(gv) ? sv_2mortal(newRV_inc((SV*)GvCV(gv))) : (SV*)gv;

        *count = call_sv(rv, G_SCALAR | G_EVAL);
        SPAGAIN;

        handle_p5_error(err);
        retval = pop_return_values(my_perl, sp, *count, type);

        FREETMPS;
        LEAVE;

        return retval;
    }
}

SV *p5_call_method(PerlInterpreter *my_perl, SV *obj, I32 context, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        int i;
        SV * retval = NULL;
        int flags = (context ? G_SCALAR : G_ARRAY) | G_EVAL;

        ENTER;
        SAVETMPS;

        HV * const pkg = SvSTASH((SV*)SvRV(obj));
        GV * const gv = gv_fetchmethod_autoload(pkg, name, TRUE);
        if (gv && isGV(gv)) {
            PUSHMARK(SP);

            if (len > 1) {
                XPUSHs(args[0]);
                for (i = 1; i < len; i++) {
                    if (args[i] != NULL) /* skip Nil which gets turned into NULL */
                        XPUSHs(sv_2mortal(args[i]));
                }
            }
            else if (len > 0)
                if (args != NULL) /* skip Nil which gets turned into NULL */
                    XPUSHs((SV*)args);

            PUTBACK;

            SV * const rv = GvCV(gv) ? sv_2mortal(newRV_inc((SV*)GvCV(gv))) : (SV*)gv;

            *count = call_sv(rv, flags);
            SPAGAIN;

            handle_p5_error(err);
            retval = pop_return_values(my_perl, sp, *count, type);
        }
        else {
            ERRSV = newSVpvf("Could not find method \"%s\" of \"%s\" object", name, HvNAME(pkg));
        }

        FREETMPS;
        LEAVE;

        return retval;
    }
}

SV *p5_call_parent_method(PerlInterpreter *my_perl, char *package, SV *parent_obj, I32 context, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        int i;
        SV * retval = NULL;
        int flags = (context ? G_SCALAR : G_ARRAY) | G_EVAL;

        ENTER;
        SAVETMPS;

        HV * const pkg = package != NULL ? gv_stashpv(package, 0) : SvSTASH((SV*)SvRV(parent_obj));
        GV * const gv = gv_fetchmethod_autoload(pkg, name, TRUE);
        if (gv && isGV(gv)) {
            SV * obj;

            PUSHMARK(SP);

            obj = len > 1 ? args[0] : (SV*) args;

            if (len > 1) {
                XPUSHs(obj);
                for (i = 1; i < len; i++) {
                    if (args[i] != NULL) /* skip Nil which gets turned into NULL */
                        XPUSHs(sv_2mortal(args[i]));
                }
            }
            else if (len > 0)
                if (args != NULL) /* skip Nil which gets turned into NULL */
                    XPUSHs(obj);

            PUTBACK;

            SV * const rv = GvCV(gv) ? sv_2mortal(newRV_inc((SV*)GvCV(gv))) : (SV*)gv;

            *count = call_sv(rv, flags);
            SPAGAIN;

            handle_p5_error(err);
            retval = pop_return_values(my_perl, sp, *count, type);

            if (p5_is_live_wrapped_p6_object(my_perl, SvRV(obj))) {
                reset_wrapped_object(my_perl, obj);
                SPAGAIN;
                SvREFCNT_dec(obj);
            }
        }

        FREETMPS;
        LEAVE;

        return retval;
    }
}

SV *p5_call_function(PerlInterpreter *my_perl, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        SV * retval = NULL;
        int flags = G_ARRAY | G_EVAL;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);
        push_arguments(sp, len, args);

        *count = call_pv(name, flags);
        SPAGAIN;

        handle_p5_error(err);
        retval = pop_return_values(my_perl, sp, *count, type);

        FREETMPS;
        LEAVE;

        return retval;
    }
}

SV *p5_call_code_ref(PerlInterpreter *my_perl, SV *code_ref, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
    PERL_SET_CONTEXT(my_perl);
    {
        dSP;
        SV * retval = NULL;
        int flags = G_ARRAY | G_EVAL;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);
        push_arguments(sp, len, args);

        *count = call_sv(code_ref, flags);
        SPAGAIN;

        handle_p5_error(err);
        retval = pop_return_values(my_perl, sp, *count, type);

        FREETMPS;
        LEAVE;

        return retval;
    }
}

#define PERL6_MAGIC_KEY 0x0DD515FE
#define PERL6_HASH_MAGIC_KEY 0x0DD515FF
#define PERL6_EXTENSION_MAGIC_KEY 0x0DD51600

int p5_free_perl6_obj(pTHX_ SV* obj, MAGIC *mg)
{
    if (mg && ((_perl6_magic*) mg->mg_ptr)->index != -1) {
        _perl6_magic* const p6mg = (_perl6_magic*) mg->mg_ptr;
        /* need to be extra careful here as PL_modglobal could have been cleaned already */
        SV **cbs_entry = hv_fetchs(PL_modglobal, "Inline::Perl5 callbacks", 0);
        if (cbs_entry) {
            perl6_callbacks *cbs = (perl6_callbacks*)SvIV(*cbs_entry);
            cbs->free_p6_object(p6mg->index);
        }
    }
    return 0;
}

int p5_free_wrapped_perl6_obj(pTHX_ SV* obj, MAGIC *mg)
{
    if (mg) {
        _perl6_magic* const p6mg = (_perl6_magic*) mg->mg_ptr;
        /* need to be extra careful here as PL_modglobal could have been cleaned already */
        if (p6mg->index != -1) {
            SV **cbs_entry = hv_fetchs(PL_modglobal, "Inline::Perl5 callbacks", 0);
            if (cbs_entry) {
                perl6_callbacks *cbs = (perl6_callbacks*)SvIV(*cbs_entry);
                cbs->free_p6_object(p6mg->index);
            }
            p6mg->index = -1;
        }
    }
    return 0;
}

int p5_free_perl6_hash(pTHX_ SV* obj, MAGIC *mg)
{
    if (mg) {
        _perl6_hash_magic* const p6mg = (_perl6_hash_magic*) mg->mg_ptr;
        /* need to be extra careful here as PL_modglobal could have been cleaned already */
        SV **cbs_entry = hv_fetchs(PL_modglobal, "Inline::Perl5 callbacks", 0);
        if (cbs_entry) {
            perl6_callbacks *cbs = (perl6_callbacks*)SvIV(*cbs_entry);
            cbs->free_p6_object(p6mg->index);
        }
    }
    return 0;
}

MGVTBL p5_inline_mg_vtbl = {
    0x0,
    0x0,
    0x0,
    0x0,
    &p5_free_perl6_obj,
    0x0,
    0x0,
    0x0
};

MGVTBL p5_inline_wrapped_mg_vtbl = {
    0x0,
    0x0,
    0x0,
    0x0,
    &p5_free_wrapped_perl6_obj,
    0x0,
    0x0,
    0x0
};

MGVTBL p5_inline_hash_mg_vtbl = {
    0x0,
    0x0,
    0x0,
    0x0,
    &p5_free_perl6_hash,
    0x0,
    0x0,
    0x0
};

SV *p5_add_magic(PerlInterpreter *my_perl, SV *inst, IV i) {
    PERL_SET_CONTEXT(my_perl);
    {
        MAGIC * const mg = mg_find(inst, '~');
        if (mg && mg->mg_ptr && ((_perl6_magic*)(mg->mg_ptr))->key == PERL6_MAGIC_KEY) {
            ((_perl6_magic*)(mg->mg_ptr))->index = i;
        }
        else {
            _perl6_magic priv;

            /* set up magic */
            priv.key = PERL6_MAGIC_KEY;
            priv.index = i;
            priv.is_wrapper = 1;
            sv_magicext(inst, inst, PERL_MAGIC_ext, &p5_inline_mg_vtbl, (char *) &priv, sizeof(priv));
        }
        return newRV_noinc(inst);
    }
}

SV *p5_wrap_p6_object(PerlInterpreter *my_perl, IV i, SV *p5obj) {
    PERL_SET_CONTEXT(my_perl);
    {
        SV * inst;
        SV * inst_ptr;
        if (p5obj == NULL) {
            inst_ptr = newSViv(0); // will be upgraded to an RV
            inst = newSVrv(inst_ptr, "Perl6::Object");
        }
        else {
            inst_ptr = p5obj;
            inst = SvRV(inst_ptr);
        }
        _perl6_magic priv;

        /* set up magic */
        priv.key = p5obj == NULL ? PERL6_MAGIC_KEY : PERL6_EXTENSION_MAGIC_KEY;
        priv.index = i;
        priv.is_wrapper = 0;
        sv_magicext(inst, inst, PERL_MAGIC_ext, &p5_inline_mg_vtbl, (char *) &priv, sizeof(priv));

        return inst_ptr;
    }
}

SV *p5_wrap_p6_callable(PerlInterpreter *my_perl, IV i, SV *p5obj) {
    SV * inst;
    SV * inst_ptr;

    PERL_SET_CONTEXT(my_perl);

    if (p5obj == NULL) {
        dSP;
        ENTER;
        SAVETMPS;

        PUSHMARK(SP);
        XPUSHs(sv_2mortal(newSViv(i)));
        PUTBACK;
        call_pv("Perl6::Callable::new", G_SCALAR);
        SPAGAIN;

        inst_ptr = POPs;
        inst = SvRV(inst_ptr);
        SvREFCNT_inc(inst_ptr);

        PUTBACK;
        FREETMPS;
        LEAVE;
    }
    else {
        inst_ptr = p5obj;
        inst = SvRV(inst_ptr);
        SvREFCNT_inc(inst_ptr);
    }
    _perl6_magic priv;

    /* set up magic */
    priv.key = PERL6_MAGIC_KEY;
    priv.index = i;
    priv.is_wrapper = 0;
    sv_magic(inst, inst, PERL_MAGIC_ext, (char *) &priv, sizeof(priv));
    MAGIC * const mg = mg_find(inst, PERL_MAGIC_ext);
    mg->mg_virtual = &p5_inline_mg_vtbl;

    return inst_ptr;
}

SV *p5_wrap_p6_hash(
    PerlInterpreter *my_perl,
    IV i
) {
    PERL_SET_CONTEXT(my_perl);
    {
        int flags = G_SCALAR;
        dSP;

        SV * inst;
        SV * inst_ptr;
        inst_ptr = newSViv(0); // will be upgraded to an RV
        inst = newSVrv(inst_ptr, "Perl6::Object");
        _perl6_hash_magic priv;

        /* set up magic */
        priv.key = PERL6_HASH_MAGIC_KEY;
        priv.index = i;
        sv_magicext(inst, inst, PERL_MAGIC_ext, &p5_inline_hash_mg_vtbl, (char *) &priv, sizeof(priv));

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);

        XPUSHs(sv_2mortal(newSVpv("Perl6::Hash", 0)));
        XPUSHs(sv_2mortal(inst_ptr));

        PUTBACK;

        call_method("new", flags);
        SPAGAIN;

        SV *tied_handle = POPs;
        SvREFCNT_inc(tied_handle);

        PUTBACK;
        FREETMPS;
        LEAVE;

        return tied_handle;
    }
}

SV *p5_wrap_p6_handle(PerlInterpreter *my_perl, IV i, SV *p5obj) {
    PERL_SET_CONTEXT(my_perl);
    {
        SV *handle = p5_wrap_p6_object(my_perl, i, p5obj);
        int flags = G_SCALAR;
        dSP;

        ENTER;
        SAVETMPS;

        PUSHMARK(SP);

        XPUSHs(sv_2mortal(newSVpv("Perl6::Handle", 0)));
        XPUSHs(sv_2mortal(handle));

        PUTBACK;

        call_method("new", flags);
        SPAGAIN;

        SV *tied_handle = POPs;
        SvREFCNT_inc(tied_handle);

        PUTBACK;
        FREETMPS;
        LEAVE;

        return tied_handle;
    }
}

int p5_is_wrapped_p6_object(PerlInterpreter *my_perl, SV *obj) {
    PERL_SET_CONTEXT(my_perl);
    {
        SV * const obj_deref = SvRV(obj);
        /* check for magic! */
        MAGIC * const mg = mg_find(obj_deref, '~');
        return (mg && mg->mg_ptr && ((_perl6_magic*)(mg->mg_ptr))->key == PERL6_MAGIC_KEY);
    }
}

int p5_is_live_wrapped_p6_object(PerlInterpreter *my_perl, SV *obj) {
    PERL_SET_CONTEXT(my_perl);
    {
        /* check for magic! */
        MAGIC * const mg = mg_find(obj, '~');
        return (
            mg
            && mg->mg_ptr
            && ((_perl6_magic*)(mg->mg_ptr))->key == PERL6_MAGIC_KEY
            && ((_perl6_magic*)(mg->mg_ptr))->index != -1
            && ((_perl6_magic*)(mg->mg_ptr))->is_wrapper == 1
        );
    }
}

IV p5_unwrap_p6_object(PerlInterpreter *my_perl, SV *obj) {
    PERL_SET_CONTEXT(my_perl);
    {
        SV * const obj_deref = SvRV(obj);
        MAGIC * const mg = mg_find(obj_deref, '~');
        return ((_perl6_magic*)(mg->mg_ptr))->index;
    }
}

AV *create_args_array(const I32 ax, I32 items, I32 num_fixed_args) {
    AV * args = newAV();
    av_extend(args, items - num_fixed_args);
    int i;
    for (i = 0; i < items - num_fixed_args; i++) {
        SV * const next = SvREFCNT_inc(ST(i + num_fixed_args));
        if (av_store(args, i, next) == NULL)
            SvREFCNT_dec(next); /* see perlguts Working with AVs */
    }
    return args;
}

void return_retval(const I32 ax, SV **sp, SV *retval) {
    if (retval == NULL || GIMME_V == G_VOID) {
        XSRETURN_EMPTY;
    }
    if (GIMME_V == G_ARRAY) {
        if (SvTYPE(retval) == SVt_PVAV) {
            AV* const av = (AV*)retval;
            I32 const len = av_len(av) + 1;
            I32 i;
            for (i = 0; i < len; i++) {
                XPUSHs(sv_2mortal(av_shift(av)));
            }
            XSRETURN(len);
        }
        else {
            XPUSHs(retval);
            XSRETURN(1);
        }
    }
    else {
        if (SvROK(retval) && SvTYPE(SvRV(retval)) == SVt_PVAV) {
            XPUSHs(retval);
            XSRETURN(1);
        }
        else if (SvTYPE(retval) == SVt_PVAV) {
            AV* const av = (AV*)retval;
            XPUSHs(sv_2mortal(av_shift(av)));
            XSRETURN(1);
        }
        else {
            XPUSHs(retval);
            XSRETURN(1);
        }
    }
}

void handle_p6_error(SV *err) {
    if (err) {
        sv_2mortal(err);
        croak_sv(err);
    }
}

void post_callback(const I32 ax, SV **sp, I32 items, SV * const args_rv, SV *err, SV *retval) {
    /* refresh local stack pointer, could have been modified by Perl 5 code called from Perl 6 */
    SPAGAIN;
    SvREFCNT_dec(args_rv);
    handle_p6_error(err);
    sv_2mortal(retval);
    sp -= items;
    return_retval(ax, sp, retval);
}

XS(p5_call_p6_method) {
    dXSARGS;
    SV * name = ST(0);
    SV * obj = ST(1);

    AV *args = create_args_array(ax, items, 2);

    STRLEN len;
    char * const name_pv  = SvPV(name, len);

    if (!SvROK(obj)) {
        croak("Got a non-reference for obj in p5_call_p6_method calling %s?!", name_pv);
    }
    SV * const obj_deref = SvRV(obj);
    MAGIC * const mg = mg_find(obj_deref, '~');
    if (!mg) {
        XSRETURN_EMPTY;
        return;
    }
    _perl6_magic* const p6mg = (_perl6_magic*)(mg->mg_ptr);
    if (p6mg->index < 0) {
        if (PL_in_clean_objs || PL_in_clean_all || 0 == strcmp(name_pv, "can")) {
            XSRETURN_EMPTY;
            return;
        }
        else {
            croak("p5_call_p6_method %s on a reset object?", name_pv);
        }
    }
    SV *err = NULL;
    SV * const args_rv = newRV_noinc((SV *) args);

    declare_cbs;
    SV * retval = cbs->call_p6_method(p6mg->index, name_pv, GIMME_V == G_SCALAR, args_rv, &err);
    post_callback(ax, sp, items, args_rv, err, retval);
}

XS(p5_destroy_p5_object) {
    dXSARGS;
    SV * obj = ST(0);
    SV * const inst = SvRV(obj);
    MAGIC * mg = mg_find(inst, '~');
    int destroyed = 1;
    if (mg) {
        _perl6_magic* const p6mg = (_perl6_magic*) mg->mg_ptr;
        /* need to be extra careful here as PL_modglobal could have been cleaned already */
        if (
            (      p6mg->key == PERL6_MAGIC_KEY
                || p6mg->key == PERL6_HASH_MAGIC_KEY
                || p6mg->key == PERL6_EXTENSION_MAGIC_KEY
            )
            && p6mg->index != -1
            && !PL_in_clean_objs
        ) {
            SV **cbs_entry = hv_fetchs(PL_modglobal, "Inline::Perl5 callbacks", 0);
            if (cbs_entry) {
                perl6_callbacks *cbs = (perl6_callbacks*)SvIV(*cbs_entry);
                cbs->free_p6_object(p6mg->index);
            }
            p6mg->index = -1;
            SvREFCNT_inc(inst); // resurrect it!
            destroyed = 0;
        }
    }
    sp -= items;
    XPUSHs(sv_2mortal(newSViv(destroyed && !PL_in_clean_objs)));
    XSRETURN(1);
}

MAGIC *find_shadow_magic(SV *p6cb, SV *static_class, SV *obj) {
    SV * const obj_deref = SvRV(obj);
    MAGIC * mg = mg_find(obj_deref, '~');
    if (mg == NULL || ((_perl6_magic*)(mg->mg_ptr))->key != PERL6_EXTENSION_MAGIC_KEY) {
        /* need to create the shadow object here */

        AV * method_args = newAV();
        SV * method_args_rv = newRV_noinc((SV *) method_args);
        av_extend(method_args, 1);
        SvREFCNT_inc(obj);
        av_store(method_args, 0, obj);

        AV * args = newAV();
        av_extend(args, 3);
        SvREFCNT_inc(static_class);
        av_store(args, 0, static_class);
        av_store(args, 1, newSVpvs("new_shadow_of_p5_object"));
        av_store(args, 2, method_args_rv);

        MAGIC * const p6cb_mg = mg_find(SvRV(p6cb), '~');
        _perl6_magic* const p6cb_p6mg = (_perl6_magic*)(p6cb_mg->mg_ptr);
        SV *err = NULL;
        SV * const args_rv = newRV_noinc((SV *) args);

        declare_cbs;
        cbs->call_p6_method(p6cb_p6mg->index, "invoke", 1, args_rv, &err);
        SvREFCNT_dec(args_rv);
        handle_p6_error(err);

        mg = mg_find(obj_deref, '~');
    }
    return mg;
}

XS(p5_call_p6_extension_method) {
    dXSARGS;
    SV * p6cb = ST(0);
    SV * static_class = ST(1);
    SV * name = ST(2);
    SV * obj = ST(3);
    SV * err = NULL;

    STRLEN len;
    char * const name_pv  = SvPV(name, len);

    if (!SvROK(obj)) {
        if (SvPOK(obj)) {
            char * const package_pv  = SvPV(obj, len);
            AV *args = create_args_array(ax, items, 4);
            SV * const args_rv = newRV_noinc((SV *) args);
            declare_cbs;
            SV * retval = cbs->call_p6_package_method(package_pv, name_pv, GIMME_V == G_SCALAR, args_rv, &err);
            post_callback(ax, sp, items, args_rv, err, retval);
            return;
        }
        else {
            croak("Got a non-reference for obj in p5_call_p6_extension_method?!");
        }
    }
    MAGIC * mg = find_shadow_magic(p6cb, static_class, obj);
    _perl6_magic* const p6mg = (_perl6_magic*)(mg->mg_ptr);

    AV *args = create_args_array(ax, items, 4);
    SV * const args_rv = newRV_noinc((SV *) args);

    declare_cbs;
    SV * retval = cbs->call_p6_method(p6mg->index, name_pv, GIMME_V == G_SCALAR, args_rv, &err);
    post_callback(ax, sp, items, args_rv, err, retval);
}

XS(p5_hash_at_key) {
    dXSARGS;
    SV * self = ST(0);
    SV * key  = ST(1);

    SV * const p6hashobj = *(av_fetch((AV *) SvRV(self), 0, 0));
    MAGIC * const mg = mg_find(SvRV(p6hashobj), '~');
    _perl6_hash_magic* const p6mg = (_perl6_hash_magic*)(mg->mg_ptr);

    STRLEN len;
    char * const key_pv  = SvPV(key, len);

    declare_cbs;
    SV * retval = cbs->hash_at_key(p6mg->index, key_pv);

    sv_2mortal(retval);
    sp -= items;

    XPUSHs(retval);
    XSRETURN(1);
}

XS(p5_hash_assign_key) {
    dXSARGS;
    SV * self = ST(0);
    SV * key  = ST(1);
    SV * val  = ST(2);

    SV * const p6hashobj = *(av_fetch((AV *) SvRV(self), 0, 0));
    MAGIC * const mg = mg_find(SvRV(p6hashobj), '~');
    _perl6_hash_magic* const p6mg = (_perl6_hash_magic*)(mg->mg_ptr);

    STRLEN len;
    char * const key_pv  = SvPV(key, len);

    declare_cbs;
    cbs->hash_assign_key(p6mg->index, key_pv, val);

    sp -= items;

    XSRETURN_EMPTY;
}

XS(p5_call_p6_callable) {
    dXSARGS;
    SV * index = ST(0);

    AV *args = create_args_array(ax, items, 1);

    SV *err = NULL;
    SV * const args_rv = newRV_noinc((SV *) args);

    declare_cbs;
    SV * retval = cbs->call_p6_callable(SvIV(index), args_rv, &err);
    post_callback(ax, sp, items, args_rv, err, retval);
}

XS(p5_load_module) {
    dXSARGS;
    SV * module  = ST(0);
    SV * version = NULL;
    SvREFCNT_inc(module);  /* decremented by load_module */
    if (items == 2) {
        version = ST(1);
        SvREFCNT_inc(version); /* decremented by load_module */
    }
    load_module(PERL_LOADMOD_NOIMPORT, module, version);
    SPAGAIN;
    sp -= items;
    XSRETURN_EMPTY;
}

static MGVTBL subname_vtbl;

XS(p5_set_subname) {
    dXSARGS;
    SV *package = ST(0);
    SV *name    = ST(1);
    SV *sub     = ST(2);
    CV *code    = (CV *) SvRV(sub);
    HV *stash   = GvHV(gv_fetchsv(package, TRUE, SVt_PVHV));
    GV *gv = (GV *) newSV(0);
    MAGIC *mg;

    gv_init_sv(gv, stash, name, GV_ADDMULTI);

    /*
     * p5_set_subname needs to create a GV to store the name. The CvGV field of
     * a CV is not refcounted, so perl wouldn't know to SvREFCNT_dec() this GV
     * if it destroys the containing CV. We use a MAGIC with an empty vtable
     * simply for the side-effect of using MGf_REFCOUNTED to store the
     * actually-counted reference to the GV.
     */
    Newxz(mg, 1, MAGIC);
    mg->mg_moremagic = SvMAGIC(code);
    mg->mg_type = PERL_MAGIC_ext;
    mg->mg_virtual = &subname_vtbl;
    SvMAGIC_set(code, mg);
    mg->mg_flags |= MGf_REFCOUNTED;
    mg->mg_obj = (SV *) gv;
    SvRMAGICAL_on(code);
    CvANON_off(code);
#ifndef CvGV_set
    CvGV(code) = gv;
#else
    CvGV_set(code, gv);
#endif
    sp -= items;
    PUSHs(sub);
    XSRETURN(1);
}