source: branches/stable/PERL2ARB/ARB_ext.c

Last change on this file was 11401, checked in by westram, 6 years ago
  • reintegrates 'tree' into 'trunk':
    • consensus trees:
      • support for merging partial trees ("worked" before, but results were crap; implements #65)
      • generated trees are automatically re-rooted and -ordered
      • always list source trees in consensus-tree-comment; show info about partial trees
      • fixed progress bar
    • made GBT_TREE a base class of other tree classes (implements #31)
    • save tree properties in properties (not in DB)
    • new functions 'Remove zombies/marked from ALL trees'
    • tree load/save: layout fixes
    • unit tests
      • added tests for basic tree modifications (PARSIMONY)
    • performance:
      • compute_tree updates tree information in one traversal
      • tree generators are now capable to generate any type of tree (w/o needing to copy it once)
    • bugfixes:
      • NNI (of marked species) was also always performed for colored species
      • centered beautify-order is stable now
      • improved 'search optimal root'
  • adds:
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 3.4 KB
Line 
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
13char *static_pntr                 = 0; // see ../PERLTOOLS/arb_proto_2_xsub.cxx@static_pntr
14
15static GB_HASH *gbp_cp_hash_table = 0;
16
17// defined in ../ARBDB/adperl.c@GBP_croak_function
18extern 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
24void 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
50inline 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
54GB_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
76GB_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
95struct ARB_init_perl_interface {
96    ARB_init_perl_interface() {
97        GBP_croak_function = GBP_croak;
98    }
99};
100
101static ARB_init_perl_interface init; /* automatically initialize this module */
102
103
Note: See TracBrowser for help on using the repository browser.