source: tags/svn.1.5.4/PERL2ARB/ARB_ext.c

/* ================================================================ */
/*                                                                  */
/*   File      : ARB_ext.c                                          */
/*   Purpose   : additional code for perllib                        */
/*                                                                  */
/*   Institute of Microbiology (Technical University Munich)        */
/*   http://www.arb-home.de/                                        */
/*                                                                  */
/* ================================================================ */


char *static_pntr                 = 0; // see ../PERLTOOLS/arb_proto_2_xsub.cxx@static_pntr

static GB_HASH *gbp_cp_hash_table = 0;

// defined in ../ARBDB/adperl.c@GBP_croak_function
extern void (*GBP_croak_function)(const char *message);

void GBP_croak(const char *message) {
    Perl_croak(aTHX_ "ARBDB croaks %s", message);
}

void GBP_callback(GBDATA *gbd, int *cl, GB_CB_TYPE cb_type) {
    char *perl_func;
    char *perl_cl;
    dSP;
    I32   i;
    SV   *sv;

    // cl contains 'func\0cl'
    perl_func = (char *)cl;
    perl_cl   = perl_func + strlen(perl_func) + 1;

    PUSHMARK(sp);
    sv =  sv_newmortal();
    sv_setref_pv(sv, "GBDATAPtr", (void*)gbd);
    XPUSHs(sv);
    XPUSHs(sv_2mortal(newSVpv(perl_cl, 0)));
    if (cb_type & GB_CB_DELETE) {
        XPUSHs(sv_2mortal(newSVpv("DELETED", 0)));
    }
    else {
        XPUSHs(sv_2mortal(newSVpv("CHANGED", 0)));
    }

    PUTBACK;
    i = perl_call_pv(perl_func, G_DISCARD);
    if (i) {
        croak("Your perl function '%s' should not return any values", perl_func);
    }
    return;
}

inline char *gbp_create_callback_hashkey(GBDATA *gbd, const char *perl_func, const char *perl_cl) {
    return GBS_global_string_copy("%p:%s%c%s", gbd, perl_func, '\1', perl_cl);
}

GB_ERROR GBP_add_callback(GBDATA *gbd, const char *perl_func, const char *perl_cl) {
    if (!gbp_cp_hash_table) gbp_cp_hash_table = GBS_create_hash(20, GB_MIND_CASE);

    char     *data  = gbp_create_callback_hashkey(gbd, perl_func, perl_cl);
    GB_ERROR  error = 0;

    if (GBS_read_hash(gbp_cp_hash_table, data)) {
        error = GBS_global_string("Error: Callback '%s:%s' is already installed", perl_func, perl_cl);
    }
    else {
        char *arg = GBS_global_string_copy("%s%c%s", perl_func, '\0', perl_cl);

        GBS_write_hash(gbp_cp_hash_table, data, (long)arg);
        error = GB_add_callback(gbd, GB_CB_TYPE(GB_CB_DELETE|GB_CB_CHANGED), GBP_callback, (int *)arg);

        GBS_optimize_hash(gbp_cp_hash_table);
    }
    free(data);

    return error;
}

GB_ERROR GBP_remove_callback(GBDATA *gbd, const char *perl_func, const char *perl_cl) {
    GB_ERROR  error = 0;
    char     *data  = gbp_create_callback_hashkey(gbd, perl_func, perl_cl);
    char     *arg   = gbp_cp_hash_table ? (char *)GBS_read_hash(gbp_cp_hash_table, data) : (char*)NULL;

    if (!arg) {
        error = GBS_global_string("Error: You never installed a callback '%s:%s'", perl_func, perl_cl);
    }
    else {
        GBS_write_hash(gbp_cp_hash_table, data, 0); 
        GB_remove_callback(gbd, GB_CB_TYPE(GB_CB_DELETE|GB_CB_CHANGED), GBP_callback, (int *)arg);
        free(arg);
    }
    free(data);

    return error;
}


class ARB_init_perl_interface {
 public:
    ARB_init_perl_interface() {
        GBP_croak_function = GBP_croak;
    }
};

static ARB_init_perl_interface init; /* automatically initialize this module */