ARB
ARB_ext.c
Go to the documentation of this file.
1 /* ================================================================ */
2 /* */
3 /* File : ARB_ext.c */
4 /* Purpose : additional code for perllib */
5 /* */
6 /* Institute of Microbiology (Technical University Munich) */
7 /* http://www.arb-home.de/ */
8 /* */
9 /* ================================================================ */
10 
11 #include <ad_cb.h>
12 
13 char *static_pntr = 0; // see ../PERLTOOLS/arb_proto_2_xsub.cxx@static_pntr
14 
16 
17 // defined in ../ARBDB/adperl.c@GBP_croak_function
18 extern void (*GBP_croak_function)(const char *message);
19 
20 __ATTR__NORETURN static void GBP_croak(const char *message) {
21  Perl_croak(aTHX_ "ARBDB croaks %s", message);
22 }
23 
24 void GBP_callback(GBDATA *gbd, const char *perl_func, GB_CB_TYPE cb_type) {
25  // perl_func contains 'func\0cl'
26  dSP;
27 
28  const char *perl_cl = perl_func + strlen(perl_func) + 1;
29 
30  PUSHMARK(sp);
31  SV *sv = sv_newmortal();
32  sv_setref_pv(sv, "GBDATAPtr", (void*)gbd);
33  XPUSHs(sv);
34  XPUSHs(sv_2mortal(newSVpv(perl_cl, 0)));
35  if (cb_type & GB_CB_DELETE) {
36  XPUSHs(sv_2mortal(newSVpv("DELETED", 0)));
37  }
38  else {
39  XPUSHs(sv_2mortal(newSVpv("CHANGED", 0)));
40  }
41 
42  PUTBACK;
43  I32 i = perl_call_pv(perl_func, G_DISCARD);
44  if (i) {
45  croak("Your perl function '%s' should not return any values", perl_func);
46  }
47  return;
48 }
49 
50 inline char *gbp_create_callback_hashkey(GBDATA *gbd, const char *perl_func, const char *perl_cl) {
51  return GBS_global_string_copy("%p:%s%c%s", gbd, perl_func, '\1', perl_cl);
52 }
53 
54 GB_ERROR GBP_add_callback(GBDATA *gbd, const char *perl_func, const char *perl_cl) {
55  if (!gbp_cp_hash_table) gbp_cp_hash_table = GBS_create_hash(20, GB_MIND_CASE);
56 
57  char *data = gbp_create_callback_hashkey(gbd, perl_func, perl_cl);
58  GB_ERROR error = 0;
59 
60  if (GBS_read_hash(gbp_cp_hash_table, data)) {
61  error = GBS_global_string("Error: Callback '%s:%s' is already installed", perl_func, perl_cl);
62  }
63  else {
64  char *arg = GBS_global_string_copy("%s%c%s", perl_func, '\0', perl_cl);
65 
66  GBS_write_hash(gbp_cp_hash_table, data, (long)arg);
67  error = GB_add_callback(gbd, GB_CB_CHANGED_OR_DELETED, makeDatabaseCallback(GBP_callback, arg));
68 
69  GBS_optimize_hash(gbp_cp_hash_table);
70  }
71  free(data);
72 
73  return error;
74 }
75 
76 GB_ERROR GBP_remove_callback(GBDATA *gbd, const char *perl_func, const char *perl_cl) {
77  GB_ERROR error = 0;
78  char *data = gbp_create_callback_hashkey(gbd, perl_func, perl_cl);
79  char *arg = gbp_cp_hash_table ? (char *)GBS_read_hash(gbp_cp_hash_table, data) : (char*)NULL;
80 
81  if (!arg) {
82  error = GBS_global_string("Error: You never installed a callback '%s:%s'", perl_func, perl_cl);
83  }
84  else {
85  GBS_write_hash(gbp_cp_hash_table, data, 0);
86  GB_remove_callback(gbd, GB_CB_CHANGED_OR_DELETED, makeDatabaseCallback(GBP_callback, arg));
87  free(arg);
88  }
89  free(data);
90 
91  return error;
92 }
93 
94 
98  }
99 };
100 
101 static ARB_init_perl_interface init; /* automatically initialize this module */
102 
103 
const char * GB_ERROR
Definition: arb_core.h:25
long GBS_write_hash(GB_HASH *hs, const char *key, long val)
Definition: adhash.cxx:457
GB_ERROR GB_add_callback(GBDATA *gbd, GB_CB_TYPE type, const DatabaseCallback &dbcb)
Definition: ad_cb.cxx:356
void GBP_callback(GBDATA *gbd, const char *perl_func, GB_CB_TYPE cb_type)
Definition: ARB_ext.c:24
static GB_HASH * gbp_cp_hash_table
Definition: ARB_ext.c:15
char * gbp_create_callback_hashkey(GBDATA *gbd, const char *perl_func, const char *perl_cl)
Definition: ARB_ext.c:50
const char * GBS_global_string(const char *templat,...)
Definition: arb_msg.cxx:204
void(* GBP_croak_function)(const char *message)
Definition: adperl.cxx:16
void message(char *errortext)
char * static_pntr
Definition: ARB_ext.c:13
static void error(const char *msg)
Definition: mkptypes.cxx:96
GB_ERROR GBP_remove_callback(GBDATA *gbd, const char *perl_func, const char *perl_cl)
Definition: ARB_ext.c:76
GB_ERROR GBP_add_callback(GBDATA *gbd, const char *perl_func, const char *perl_cl)
Definition: ARB_ext.c:54
void GB_remove_callback(GBDATA *gbd, GB_CB_TYPE type, const DatabaseCallback &dbcb)
Definition: ad_cb.cxx:360
static ARB_init_perl_interface init
Definition: ARB_ext.c:101
static __ATTR__NORETURN void GBP_croak(const char *message)
Definition: ARB_ext.c:20
#define __ATTR__NORETURN
Definition: attributes.h:56
GB_CB_TYPE
Definition: arbdb_base.h:46
long GBS_read_hash(const GB_HASH *hs, const char *key)
Definition: adhash.cxx:395
char * GBS_global_string_copy(const char *templat,...)
Definition: arb_msg.cxx:195
void GBS_optimize_hash(const GB_HASH *hs)
Definition: adhash.cxx:316
GB_HASH * GBS_create_hash(long estimated_elements, GB_CASE case_sens)
Definition: adhash.cxx:253