/********************************************************************\ * engine-helpers.c -- gnucash g-wrap helper functions * * Copyright (C) 2000 Linas Vepstas * * Copyright (C) 2001 Linux Developers Group, Inc. * * * * This program is free software; you can redistribute it and/or * * modify it under the terms of the GNU General Public License as * * published by the Free Software Foundation; either version 2 of * * the License, or (at your option) any later version. * * * * This program is distributed in the hope that it will be useful, * * but WITHOUT ANY WARRANTY; without even the implied warranty of * * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * * GNU General Public License for more details. * * * * You should have received a copy of the GNU General Public License* * along with this program; if not, contact: * * * * Free Software Foundation Voice: +1-617-542-5942 * * 59 Temple Place - Suite 330 Fax: +1-617-542-2652 * * Boston, MA 02111-1307, USA gnu@gnu.org * * * \********************************************************************/ #include "config.h" #include "gnc-engine-util.h" #include "gnc-engine.h" #include "gnc-numeric.h" #include "gnc-book.h" #include "Backend.h" #include "Query.h" #include "date.h" #include "engine-helpers.h" #include "glib-helpers.h" #include #include #include gnc_commodity_table * gnc_engine_commodity_table_new (void) { static SCM commodity_table_type = SCM_UNDEFINED; gnc_commodity_table *commodity_table; SCM ct_scm; SCM func; commodity_table = gnc_commodity_table_new (); if (commodity_table_type == SCM_UNDEFINED) { commodity_table_type = gh_eval_str(""); /* don't really need this - types are bound globally anyway. */ if (commodity_table_type != SCM_UNDEFINED) scm_protect_object (commodity_table_type); } ct_scm = gw_wcp_assimilate_ptr ((void *) commodity_table, commodity_table_type); func = gh_eval_str ("gnc:engine-commodity-table-construct"); gh_call1 (func, ct_scm); return commodity_table; } Timespec gnc_transaction_get_date_posted(Transaction *t) { Timespec result; xaccTransGetDatePostedTS(t, &result); return(result); } Timespec gnc_transaction_get_date_entered(Transaction *t) { Timespec result; xaccTransGetDateEnteredTS(t, &result); return(result); } Timespec gnc_split_get_date_reconciled(Split *s) { Timespec result; xaccSplitGetDateReconciledTS(s, &result); return(result); } void gnc_transaction_set_date_posted(Transaction *t, const Timespec d) { xaccTransSetDatePostedTS(t, &d); } void gnc_transaction_set_date_entered(Transaction *t, const Timespec d) { xaccTransSetDateEnteredTS(t, &d); } void gnc_transaction_set_date(Transaction *t, Timespec ts) { xaccTransSetDatePostedTS(t, &ts); } SCM gnc_timespec2timepair(Timespec t) { SCM secs; SCM nsecs; secs = gnc_gint64_to_scm(t.tv_sec); nsecs = gh_long2scm(t.tv_nsec); return(gh_cons(secs, nsecs)); } Timespec gnc_timepair2timespec(SCM x) { Timespec result = {0,0}; if (gnc_timepair_p (x)) { result.tv_sec = gnc_scm_to_gint64(gh_car(x)); result.tv_nsec = gh_scm2long(gh_cdr(x)); } return(result); } int gnc_timepair_p(SCM x) { return(gh_pair_p(x) && gnc_gh_gint64_p(gh_car(x)) && gnc_gh_gint64_p(gh_cdr(x))); } SCM gnc_guid2scm(GUID guid) { char string[GUID_ENCODING_LENGTH + 1]; if (!guid_to_string_buff(&guid, string)) return SCM_UNDEFINED; return gh_str02scm(string); } GUID gnc_scm2guid(SCM guid_scm) { char string[GUID_ENCODING_LENGTH + 1]; GUID guid; gh_get_substr(guid_scm, string, 0, GUID_ENCODING_LENGTH); string[GUID_ENCODING_LENGTH] = '\0'; string_to_guid(string, &guid); return guid; } int gnc_guid_p(SCM guid_scm) { char string[GUID_ENCODING_LENGTH + 1]; GUID guid; if (!gh_string_p(guid_scm)) return (0 == 1); gh_get_substr(guid_scm, string, 0, GUID_ENCODING_LENGTH); string[GUID_ENCODING_LENGTH] = '\0'; return string_to_guid(string, &guid); } /******************************************************************** * type converters for query API ********************************************************************/ /* The query scm representation is a list of pairs, where the * car of each pair is one of the following symbols: * * Symbol cdr * 'terms list of OR terms * 'primary-sort scm rep of sort_type_t * 'secondary-sort scm rep of sort_type_t * 'tertiary-sort scm rep of sort_type_t * 'primary-increasing boolean * 'secondary-increasing boolean * 'tertiary-increasing boolean * 'max-splits integer * * Each OR term is a list of AND terms. * Each AND term is a list of one of the following forms: * * ('pd-date pr-type sense-bool use-start-bool start-timepair * use-end-bool use-end-timepair) * ('pd-amount pr-type sense-bool amt-match-how amt-match-sign amount) * ('pd-account pr-type sense-bool acct-match-how list-of-account-guids) * ('pd-string pr-type sense-bool case-sense-bool use-regexp-bool string) * ('pd-cleared pr-type sense-bool cleared-field) * ('pd-balance pr-type sense-bool balance-field) */ static SCM gnc_gw_enum_val2scm (const char *typestr, int value) { char *func_name; SCM func; SCM scm; func_name = g_strdup_printf ("gw:enum-%s-val->sym", typestr); func = gh_eval_str (func_name); if (gh_procedure_p (func)) scm = gh_call2 (func, gh_int2scm (value), gh_bool2scm (FALSE)); else scm = SCM_BOOL_F; g_free (func_name); return scm; } static int gnc_gw_enum_scm2val (const char *typestr, SCM enum_scm) { char *func_name; SCM func; SCM scm; func_name = g_strdup_printf ("gw:enum-%s-val->int", typestr); func = gh_eval_str (func_name); if (gh_procedure_p (func)) scm = gh_call1 (func, enum_scm); else scm = gh_int2scm (0); g_free (func_name); return gh_scm2int (scm); } static SCM gnc_query_term_type2scm (pd_type_t pd_type) { return gnc_gw_enum_val2scm ("", pd_type); } static pd_type_t gnc_query_scm2term_type (SCM pd_type_scm) { return gnc_gw_enum_scm2val ("", pd_type_scm); } static SCM gnc_query_pred_type2scm (pr_type_t pr_type) { return gnc_gw_enum_val2scm ("", pr_type); } static pr_type_t gnc_query_scm2pred_type (SCM pr_type_scm) { return gnc_gw_enum_scm2val ("", pr_type_scm); } static SCM gnc_acct_match_how2scm (acct_match_t how) { return gnc_gw_enum_val2scm ("", how); } static acct_match_t gnc_scm2acct_match_how (SCM how_scm) { return gnc_gw_enum_scm2val ("", how_scm); } static SCM gnc_amt_match_how2scm (amt_match_t how) { return gnc_gw_enum_val2scm ("", how); } static amt_match_t gnc_scm2amt_match_how (SCM how_scm) { return gnc_gw_enum_scm2val ("", how_scm); } static SCM gnc_amt_match_sign2scm (amt_match_sgn_t how) { return gnc_gw_enum_val2scm ("", how); } static amt_match_sgn_t gnc_scm2amt_match_sign (SCM how_scm) { return gnc_gw_enum_scm2val ("", how_scm); } static SCM gnc_sort_type2scm (sort_type_t sort_type) { return gnc_gw_enum_val2scm ("", sort_type); } static sort_type_t gnc_scm2sort_type (SCM sort_type_scm) { return gnc_gw_enum_scm2val ("", sort_type_scm); } static SCM gnc_bitfield2scm (const char *typestr, int value) { SCM field = SCM_EOL; int bit = 1; while (value) { if (value & bit) { SCM scm; scm = gnc_gw_enum_val2scm (typestr, bit); if (gh_symbol_p (scm)) field = gh_cons (scm, field); } value &= ~bit; bit <<= 1; } return gh_reverse (field); } static int gnc_scm2bitfield (const char *typestr, SCM field_scm) { int field = 0; if (!gh_list_p (field_scm)) return 0; while (!gh_null_p (field_scm)) { SCM scm; int bit; scm = gh_car (field_scm); field_scm = gh_cdr (field_scm); bit = gnc_gw_enum_scm2val (typestr, scm); field |= bit; } return field; } static SCM gnc_cleared_match_how2scm (cleared_match_t how) { return gnc_bitfield2scm ("", how); } static cleared_match_t gnc_scm2cleared_match_how (SCM how_scm) { return gnc_scm2bitfield ("", how_scm); } static SCM gnc_balance_match_how2scm (balance_match_t how) { return gnc_bitfield2scm ("", how); } static balance_match_t gnc_scm2balance_match_how (SCM how_scm) { return gnc_scm2bitfield ("", how_scm); } static SCM gnc_acct_guid_glist2scm (GList *account_guids) { SCM guids = SCM_EOL; GList *node; for (node = account_guids; node; node = node->next) { GUID *guid = node->data; if (guid) guids = gh_cons (gnc_guid2scm (*guid), guids); } return gh_reverse (guids); } static GList * gnc_scm2acct_guid_glist (SCM guids_scm) { GList *guids = NULL; if (!gh_list_p (guids_scm)) return NULL; while (!gh_null_p (guids_scm)) { SCM guid_scm = gh_car (guids_scm); GUID *guid; guid = xaccGUIDMalloc (); *guid = gnc_scm2guid (guid_scm); guids = g_list_prepend (guids, guid); guids_scm = gh_cdr (guids_scm); } return g_list_reverse (guids); } static void acct_guid_glist_free (GList *guids) { GList *node; for (node = guids; node; node = node->next) xaccGUIDFree (node->data); g_list_free (guids); } static SCM gnc_queryterm2scm (QueryTerm *qt) { SCM qt_scm = SCM_EOL; qt_scm = gh_cons (gnc_query_term_type2scm (qt->data.type), qt_scm); qt_scm = gh_cons (gnc_query_pred_type2scm (qt->data.base.term_type), qt_scm); qt_scm = gh_cons (gh_bool2scm (qt->data.base.sense), qt_scm); switch (qt->data.type) { case PD_DATE: qt_scm = gh_cons (gh_bool2scm (qt->data.date.use_start), qt_scm); qt_scm = gh_cons (gnc_timespec2timepair (qt->data.date.start), qt_scm); qt_scm = gh_cons (gh_bool2scm (qt->data.date.use_end), qt_scm); qt_scm = gh_cons (gnc_timespec2timepair (qt->data.date.end), qt_scm); break; case PD_AMOUNT: qt_scm = gh_cons (gnc_amt_match_how2scm (qt->data.amount.how), qt_scm); qt_scm = gh_cons (gnc_amt_match_sign2scm (qt->data.amount.amt_sgn), qt_scm); qt_scm = gh_cons (gh_double2scm (qt->data.amount.amount), qt_scm); break; case PD_ACCOUNT: qt_scm = gh_cons (gnc_acct_match_how2scm (qt->data.acct.how), qt_scm); qt_scm = gh_cons (gnc_acct_guid_glist2scm (qt->data.acct.account_guids), qt_scm); break; case PD_STRING: qt_scm = gh_cons (gh_bool2scm (qt->data.str.case_sens), qt_scm); qt_scm = gh_cons (gh_bool2scm (qt->data.str.use_regexp), qt_scm); qt_scm = gh_cons (gh_str02scm (qt->data.str.matchstring), qt_scm); break; case PD_CLEARED: qt_scm = gh_cons (gnc_cleared_match_how2scm (qt->data.cleared.how), qt_scm); break; case PD_BALANCE: qt_scm = gh_cons (gnc_balance_match_how2scm (qt->data.balance.how), qt_scm); break; case PD_GUID: qt_scm = gh_cons (gnc_guid2scm (qt->data.guid.guid), qt_scm); break; default: g_warning ("query type %d not supported", qt->data.type); return SCM_BOOL_F; } return gh_reverse (qt_scm); } static Query * gnc_scm2query_term_query (SCM query_term_scm) { gboolean ok = FALSE; pd_type_t pd_type; pr_type_t pr_type; gboolean sense; Query *q; SCM scm; if (!gh_list_p (query_term_scm) || gh_null_p (query_term_scm)) return NULL; /* pd_type */ scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); pd_type = gnc_query_scm2term_type (scm); /* pr_type */ if (gh_null_p (query_term_scm)) return NULL; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); pr_type = gnc_query_scm2pred_type (scm); /* sense */ if (gh_null_p (query_term_scm)) return NULL; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); sense = gh_scm2bool (scm); q = xaccMallocQuery (); switch (pd_type) { case PD_DATE: { gboolean use_start; gboolean use_end; Timespec start; Timespec end; /* use_start */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); use_start = gh_scm2bool (scm); /* start */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); start = gnc_timepair2timespec (scm); /* use_end */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); use_end = gh_scm2bool (scm); /* end */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); end = gnc_timepair2timespec (scm); xaccQueryAddDateMatchTS (q, use_start, start, use_end, end, QUERY_OR); } ok = TRUE; break; case PD_AMOUNT: { amt_match_t how; amt_match_sgn_t amt_sgn; double amount; /* how */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); how = gnc_scm2amt_match_how (scm); /* amt_sgn */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); amt_sgn = gnc_scm2amt_match_sign (scm); /* amount */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); amount = gh_scm2double (scm); switch (pr_type) { case PR_AMOUNT: DxaccQueryAddAmountMatch (q, amount, amt_sgn, how, QUERY_OR); ok = TRUE; break; case PR_PRICE: DxaccQueryAddSharePriceMatch (q, amount, how, QUERY_OR); ok = TRUE; break; case PR_SHRS: DxaccQueryAddSharesMatch (q, amount, how, QUERY_OR); ok = TRUE; break; default: ok = FALSE; break; } } break; case PD_ACCOUNT: { acct_match_t how; GList *account_guids; /* how */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); how = gnc_scm2acct_match_how (scm); /* account guids */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); account_guids = gnc_scm2acct_guid_glist (scm); xaccQueryAddAccountGUIDMatch (q, account_guids, how, QUERY_OR); acct_guid_glist_free (account_guids); } ok = TRUE; break; case PD_STRING: { gboolean case_sens; gboolean use_regexp; char *matchstring; /* case_sens */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); case_sens = gh_scm2bool (scm); /* use_regexp */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); use_regexp = gh_scm2bool (scm); /* matchstring */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); matchstring = gh_scm2newstr (scm, NULL); switch (pr_type) { case PR_ACTION: xaccQueryAddActionMatch (q, matchstring, case_sens, use_regexp, QUERY_OR); ok = TRUE; break; case PR_DESC: xaccQueryAddDescriptionMatch (q, matchstring, case_sens, use_regexp, QUERY_OR); ok = TRUE; break; case PR_MEMO: xaccQueryAddMemoMatch (q, matchstring, case_sens, use_regexp, QUERY_OR); ok = TRUE; break; case PR_NUM: xaccQueryAddNumberMatch (q, matchstring, case_sens, use_regexp, QUERY_OR); ok = TRUE; break; default: ok = FALSE; break; } } break; case PD_CLEARED: { cleared_match_t how; /* how */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); how = gnc_scm2cleared_match_how (scm); xaccQueryAddClearedMatch (q, how, QUERY_OR); } ok = TRUE; break; case PD_BALANCE: { balance_match_t how; /* how */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); how = gnc_scm2balance_match_how (scm); xaccQueryAddBalanceMatch (q, how, QUERY_OR); } ok = TRUE; break; case PD_GUID: { GUID guid; /* guid */ if (gh_null_p (query_term_scm)) break; scm = gh_car (query_term_scm); query_term_scm = gh_cdr (query_term_scm); guid = gnc_scm2guid (scm); xaccQueryAddGUIDMatch (q, &guid, QUERY_OR); } ok = TRUE; break; default: break; } if (ok) { Query *out_q; if (sense) out_q = q; else { out_q = xaccQueryInvert (q); xaccFreeQuery (q); } return out_q; } xaccFreeQuery (q); return NULL; } static SCM gnc_query_terms2scm (GList *terms) { SCM or_terms = SCM_EOL; GList *or_node; for (or_node = terms; or_node; or_node = or_node->next) { SCM and_terms = SCM_EOL; GList *and_node; for (and_node = or_node->data; and_node; and_node = and_node->next) { QueryTerm *qt = and_node->data; SCM qt_scm; qt_scm = gnc_queryterm2scm (qt); and_terms = gh_cons (qt_scm, and_terms); } and_terms = gh_reverse (and_terms); or_terms = gh_cons (and_terms, or_terms); } return gh_reverse (or_terms); } static Query * gnc_scm2query_and_terms (SCM and_terms) { Query *q = NULL; if (!gh_list_p (and_terms)) return NULL; while (!gh_null_p (and_terms)) { SCM term; term = gh_car (and_terms); and_terms = gh_cdr (and_terms); if (!q) q = gnc_scm2query_term_query (term); else { Query *q_and; Query *q_new; q_and = gnc_scm2query_term_query (term); if (q_and) { q_new = xaccQueryMerge (q, q_and, QUERY_AND); if (q_new) { xaccFreeQuery (q); q = q_new; } } } } return q; } static Query * gnc_scm2query_or_terms (SCM or_terms) { Query *q = NULL; if (!gh_list_p (or_terms)) return NULL; q = xaccMallocQuery (); while (!gh_null_p (or_terms)) { SCM and_terms; and_terms = gh_car (or_terms); or_terms = gh_cdr (or_terms); if (!q) q = gnc_scm2query_and_terms (and_terms); else { Query *q_or; Query *q_new; q_or = gnc_scm2query_and_terms (and_terms); if (q_or) { q_new = xaccQueryMerge (q, q_or, QUERY_OR); if (q_new) { xaccFreeQuery (q); q = q_new; } } } } return q; } SCM gnc_query2scm (Query *q) { SCM query_scm = SCM_EOL; SCM pair; if (!q) return SCM_BOOL_F; /* terms */ pair = gh_cons (gnc_query_terms2scm (xaccQueryGetTerms (q)), SCM_EOL); pair = gh_cons (gh_symbol2scm ("terms"), pair); query_scm = gh_cons (pair, query_scm); /* primary sort type */ pair = gh_cons (gnc_sort_type2scm (xaccQueryGetPrimarySortOrder (q)), SCM_EOL); pair = gh_cons (gh_symbol2scm ("primary-sort"), pair); query_scm = gh_cons (pair, query_scm); /* secondary sort type */ pair = gh_cons (gnc_sort_type2scm (xaccQueryGetSecondarySortOrder (q)), SCM_EOL); pair = gh_cons (gh_symbol2scm ("secondary-sort"), pair); query_scm = gh_cons (pair, query_scm); /* tertiary sort type */ pair = gh_cons (gnc_sort_type2scm (xaccQueryGetTertiarySortOrder (q)), SCM_EOL); pair = gh_cons (gh_symbol2scm ("tertiary-sort"), pair); query_scm = gh_cons (pair, query_scm); /* primary sort increasing */ pair = gh_cons (gh_bool2scm (xaccQueryGetSortPrimaryIncreasing (q)), SCM_EOL); pair = gh_cons (gh_symbol2scm ("primary-increasing"), pair); query_scm = gh_cons (pair, query_scm); /* secondary sort increasing */ pair = gh_cons (gh_bool2scm (xaccQueryGetSortSecondaryIncreasing (q)), SCM_EOL); pair = gh_cons (gh_symbol2scm ("secondary-increasing"), pair); query_scm = gh_cons (pair, query_scm); /* tertiary sort increasing */ pair = gh_cons (gh_bool2scm (xaccQueryGetSortTertiaryIncreasing (q)), SCM_EOL); pair = gh_cons (gh_symbol2scm ("tertiary-increasing"), pair); query_scm = gh_cons (pair, query_scm); /* max splits */ pair = gh_cons (gh_int2scm (xaccQueryGetMaxSplits (q)), SCM_EOL); pair = gh_cons (gh_symbol2scm ("max-splits"), pair); query_scm = gh_cons (pair, query_scm); return gh_reverse (query_scm); } Query * gnc_scm2query (SCM query_scm) { Query *q = NULL; gboolean ok = TRUE; sort_type_t primary_sort = BY_STANDARD; sort_type_t secondary_sort = BY_NONE; sort_type_t tertiary_sort = BY_NONE; gboolean primary_increasing = TRUE; gboolean secondary_increasing = TRUE; gboolean tertiary_increasing = TRUE; int max_splits = -1; if (!gh_list_p (query_scm)) return NULL; while (!gh_null_p (query_scm)) { char *symbol; SCM sym_scm; SCM value; SCM pair; pair = gh_car (query_scm); query_scm = gh_cdr (query_scm); if (!gh_pair_p (pair)) { ok = FALSE; break; } sym_scm = gh_car (pair); value = gh_cadr (pair); if (!gh_symbol_p (sym_scm)) { ok = FALSE; break; } symbol = gh_symbol2newstr (sym_scm, NULL); if (!symbol) { ok = FALSE; break; } if (safe_strcmp ("terms", symbol) == 0) { if (q) xaccFreeQuery (q); q = gnc_scm2query_or_terms (value); if (!q) { ok = FALSE; free (symbol); break; } } else if (safe_strcmp ("primary-sort", symbol) == 0) { if (!gh_symbol_p (value)) { ok = FALSE; free (symbol); break; } primary_sort = gnc_scm2sort_type (value); } else if (safe_strcmp ("secondary-sort", symbol) == 0) { if (!gh_symbol_p (value)) { ok = FALSE; free (symbol); break; } secondary_sort = gnc_scm2sort_type (value); } else if (safe_strcmp ("tertiary-sort", symbol) == 0) { if (!gh_symbol_p (value)) { ok = FALSE; free (symbol); break; } tertiary_sort = gnc_scm2sort_type (value); } else if (safe_strcmp ("primary-increasing", symbol) == 0) { primary_increasing = gh_scm2bool (value); } else if (safe_strcmp ("secondary-increasing", symbol) == 0) { secondary_increasing = gh_scm2bool (value); } else if (safe_strcmp ("tertiary-increasing", symbol) == 0) { tertiary_increasing = gh_scm2bool (value); } else if (safe_strcmp ("max-splits", symbol) == 0) { if (!gh_number_p (value)) { ok = FALSE; free (symbol); break; } max_splits = gh_scm2int (value); } else { ok = FALSE; free (symbol); break; } free (symbol); } if (ok) { xaccQuerySetSortOrder (q, primary_sort, secondary_sort, tertiary_sort); xaccQuerySetSortIncreasing (q, primary_increasing, secondary_increasing, tertiary_increasing); xaccQuerySetMaxSplits (q, max_splits); return q; } xaccFreeQuery (q); return NULL; } static int gnc_scm_traversal_adapter(Transaction *t, void *data) { static SCM trans_type = SCM_BOOL_F; SCM result; SCM scm_trans; SCM thunk = *((SCM *) data); if(trans_type == SCM_BOOL_F) { trans_type = gh_eval_str(""); /* don't really need this - types are bound globally anyway. */ if(trans_type != SCM_BOOL_F) scm_protect_object(trans_type); } scm_trans = gw_wcp_assimilate_ptr(t, trans_type); result = gh_call1(thunk, scm_trans); return (result != SCM_BOOL_F); } gboolean gnc_scmGroupStagedTransactionTraversal(AccountGroup *grp, unsigned int new_marker, SCM thunk) { return xaccGroupStagedTransactionTraversal(grp, new_marker, gnc_scm_traversal_adapter, &thunk); } gboolean gnc_scmAccountStagedTransactionTraversal(Account *a, unsigned int new_marker, SCM thunk) { return xaccAccountStagedTransactionTraversal(a, new_marker, gnc_scm_traversal_adapter, &thunk); } SCM gnc_gint64_to_scm(const gint64 x) { #if GUILE_LONG_LONG_OK return scm_long_long2num(x); #else const gchar negative_p = (x < 0); const guint64 magnitude = negative_p ? -x : x; const guint32 lower_half = (guint32) (magnitude & 0xFFFFFFFF); const guint32 upper_half = (guint32) (magnitude >> 32); SCM result; result = scm_sum(scm_ash(gh_ulong2scm(upper_half), SCM_MAKINUM(32)), gh_ulong2scm(lower_half)); if(negative_p) { return scm_difference(SCM_INUM0, result); } else { return result; } #endif } gint64 gnc_scm_to_gint64(SCM num) { #if GUILE_LONG_LONG_OK return scm_num2long_long(num, (char *) SCM_ARG1, "gnc_scm_to_gint64"); #else static SCM bits00to15_mask = SCM_BOOL_F; SCM magnitude = scm_abs(num); SCM bits; unsigned long c_bits; long long c_result = 0; int i; /* This doesn't work -- atm (bit-extract 4000 0 32) proves it */ /* SCM lower = scm_bit_extract(magnitude, SCM_MAKINUM(0), SCM_MAKINUM(32)); */ if (bits00to15_mask == SCM_BOOL_F) { bits00to15_mask = gh_ulong2scm(0xFFFF); scm_protect_object (bits00to15_mask); } /* * This isn't very complicated (IMHO). We work from the "top" of * the number downwards. We assume this is no more than a 64-bit * number, otherwise it will fail right away. Anyways, we keep * taking the top 16 bits of the number and move it to c_result. * Then we 'remove' those bits from the original number and continue * with the next 16 bits down, and so on. -- warlord@mit.edu * 2001/02/13 */ for (i = 48; i >=0; i-= 16) { bits = scm_ash(magnitude, SCM_MAKINUM(-i)); c_bits = gh_scm2ulong(scm_logand(bits, bits00to15_mask)); c_result += ((long long)c_bits << i); magnitude = scm_difference(magnitude, scm_ash(bits, SCM_MAKINUM(i))); } if(scm_negative_p(num) != SCM_BOOL_F) { return(- c_result); } else { return(c_result); } #endif } int gnc_gh_gint64_p(SCM num) { static int initialized = 0; static SCM maxval; static SCM minval; if(!initialized) { /* to be super safe, we have to build these manually because though we know that we have gint64's here, we *don't* know how to portably specify a 64bit constant to the compiler (i.e. like 0x7FFFFFFFFFFFFFFF). */ gint64 tmp; tmp = 0x7FFFFFFF; tmp <<= 32; tmp |= 0xFFFFFFFF; maxval = gnc_gint64_to_scm(tmp); tmp = 0x80000000; tmp <<= 32; minval = gnc_gint64_to_scm(tmp); scm_protect_object(maxval); scm_protect_object(minval); initialized = 1; } return((scm_geq_p(num, minval) != SCM_BOOL_F) && (scm_leq_p(num, maxval) != SCM_BOOL_F)); } gnc_numeric gnc_scm_to_numeric(SCM gncnum) { static SCM get_num = SCM_BOOL_F; static SCM get_denom = SCM_BOOL_F; if(get_num == SCM_BOOL_F) { get_num = gh_eval_str("gnc:gnc-numeric-num"); } if(get_denom == SCM_BOOL_F) { get_denom = gh_eval_str("gnc:gnc-numeric-denom"); } return gnc_numeric_create(gnc_scm_to_gint64(gh_call1(get_num, gncnum)), gnc_scm_to_gint64(gh_call1(get_denom, gncnum))); } SCM gnc_numeric_to_scm(gnc_numeric arg) { static SCM maker = SCM_BOOL_F; if(maker == SCM_BOOL_F) { maker = gh_eval_str("gnc:make-gnc-numeric"); } return gh_call2(maker, gnc_gint64_to_scm(gnc_numeric_num(arg)), gnc_gint64_to_scm(gnc_numeric_denom(arg))); } int gnc_numeric_p(SCM arg) { static SCM type_p = SCM_BOOL_F; SCM ret = SCM_BOOL_F; if(type_p == SCM_BOOL_F) { type_p = gh_eval_str("gnc:gnc-numeric?"); } ret = gh_call1(type_p, arg); if(ret == SCM_BOOL_F) { return FALSE; } else { return TRUE; } } static SCM gnc_glist_account_ptr_to_scm_internal (GList *account_list, gboolean free_list) { static SCM acct_type = SCM_UNDEFINED; SCM result; if (acct_type == SCM_UNDEFINED) { acct_type = gh_eval_str(""); /* don't really need this - types are bound globally anyway. */ if(acct_type != SCM_UNDEFINED) scm_protect_object(acct_type); } result = gnc_glist_to_scm_list(account_list, acct_type); if (free_list) g_list_free (account_list); return result; } /********************************************************************\ * gnc_account_list_to_scm * * Turn a list of accounts into an SCM. * * The list is freed. * * * * Args: account_list - list of accounts to SCMify * * Return: SCM list of accounts * \********************************************************************/ SCM gnc_glist_account_ptr_to_scm (GList *account_list) { return gnc_glist_account_ptr_to_scm_internal (account_list, TRUE); } /********************************************************************\ * gnc_account_list_to_scm_no_free * * Turn a list of accounts into an SCM. * * The list is not freed. * * * * Args: account_list - list of accounts to SCMify * * Return: SCM list of accounts * \********************************************************************/ SCM gnc_glist_account_ptr_to_scm_no_free (GList *account_list) { return gnc_glist_account_ptr_to_scm_internal (account_list, FALSE); } /********************************************************************\ * gnc_scm_to_account_list * * Turn an SCM into a g_malloc's account list * * * * Args: scm_list - SCM list of accounts * * Return: GList of accounts * \********************************************************************/ GList * gnc_scm_to_glist_account_ptr(SCM scm_list) { return gnc_scm_list_to_glist(scm_list); } /******************************************************************** * gnc_glist_account_ptr_p ********************************************************************/ int gnc_glist_account_ptr_p(SCM list) { return gh_list_p(list); } static SCM gnc_glist_transaction_ptr_to_scm_internal (GList *trans_list, gboolean free_list) { static SCM trans_type = SCM_UNDEFINED; SCM result; if (trans_type == SCM_UNDEFINED) { trans_type = gh_eval_str(""); /* don't really need this - types are bound globally anyway. */ if(trans_type != SCM_UNDEFINED) scm_protect_object(trans_type); } result = gnc_glist_to_scm_list(trans_list, trans_type); if (free_list) g_list_free (trans_list); return result; } SCM gnc_glist_transaction_ptr_to_scm (GList *transaction_list) { return gnc_glist_transaction_ptr_to_scm_internal (transaction_list, TRUE); } SCM gnc_glist_transaction_ptr_to_scm_no_free (GList *transaction_list) { return gnc_glist_transaction_ptr_to_scm_internal (transaction_list, FALSE); } GList * gnc_scm_to_glist_transaction_ptr (SCM scm_list) { return gnc_scm_list_to_glist (scm_list); } int gnc_glist_transaction_ptr_p (SCM list) { return gh_list_p (list); } static SCM gnc_glist_split_ptr_to_scm_internal (GList *trans_list, gboolean free_list) { static SCM trans_type = SCM_UNDEFINED; SCM result; if (trans_type == SCM_UNDEFINED) { trans_type = gh_eval_str(""); /* don't really need this - types are bound globally anyway. */ if(trans_type != SCM_UNDEFINED) scm_protect_object(trans_type); } result = gnc_glist_to_scm_list(trans_list, trans_type); if (free_list) g_list_free (trans_list); return result; } SCM gnc_glist_split_ptr_to_scm (GList *split_list) { return gnc_glist_split_ptr_to_scm_internal (split_list, TRUE); } SCM gnc_glist_split_ptr_to_scm_no_free (GList *split_list) { return gnc_glist_split_ptr_to_scm_internal (split_list, FALSE); } GList * gnc_scm_to_glist_split_ptr (SCM scm_list) { return gnc_scm_list_to_glist (scm_list); } int gnc_glist_split_ptr_p (SCM list) { return gh_list_p (list); } /******************************************************************** * gnc_scm_to_commodity ********************************************************************/ gnc_commodity * gnc_scm_to_commodity(SCM scm) { static SCM commodity_type = SCM_UNDEFINED; if(commodity_type == SCM_UNDEFINED) { commodity_type = gh_eval_str(""); /* don't really need this - types are bound globally anyway. */ if(commodity_type != SCM_UNDEFINED) scm_protect_object(commodity_type); } if(!gw_wcp_is_of_type_p(commodity_type, scm)) { return NULL; } return gw_wcp_get_ptr(scm); } /******************************************************************** * gnc_commodity_to_scm ********************************************************************/ SCM gnc_commodity_to_scm (const gnc_commodity *commodity) { static SCM commodity_type = SCM_UNDEFINED; if(commodity == NULL) return SCM_BOOL_F; if(commodity_type == SCM_UNDEFINED) { commodity_type = gh_eval_str(""); /* don't really need this - types are bound globally anyway. */ if(commodity_type != SCM_UNDEFINED) scm_protect_object(commodity_type); } return gw_wcp_assimilate_ptr((void *) commodity, commodity_type); } /******************************************************************** * gnc_book_to_scm ********************************************************************/ SCM gnc_book_to_scm (GNCBook *book) { static SCM book_type = SCM_UNDEFINED; if (!book) return SCM_BOOL_F; if (book_type == SCM_UNDEFINED) { book_type = gh_eval_str (""); /* don't really need this - types are bound globally anyway. */ if (book_type != SCM_UNDEFINED) scm_protect_object (book_type); } return gw_wcp_assimilate_ptr ((void *) book, book_type); } /******************************************************************** * gnc_session_to_scm ********************************************************************/ SCM gnc_session_to_scm (GNCSession *session) { static SCM session_type = SCM_UNDEFINED; if (!session) return SCM_BOOL_F; if (session_type == SCM_UNDEFINED) { session_type = gh_eval_str (""); /* don't really need this - types are bound globally anyway. */ if (session_type != SCM_UNDEFINED) scm_protect_object (session_type); } return gw_wcp_assimilate_ptr ((void *) session, session_type); } /******************************************************************** * gnc_glist_commodity_ptr_to_scm ********************************************************************/ SCM gnc_glist_commodity_ptr_to_scm(GList * l) { static SCM commodity_type = SCM_UNDEFINED; SCM result_list; if(commodity_type == SCM_UNDEFINED) { commodity_type = gh_eval_str(""); /* don't really need this - types are bound globally anyway. */ if(commodity_type != SCM_UNDEFINED) scm_protect_object(commodity_type); } result_list = gnc_glist_to_scm_list(l, commodity_type); g_list_free(l); return result_list; } /******************************************************************** * gnc_scm_to_glist_commodity_ptr ********************************************************************/ GList * gnc_scm_to_glist_commodity_ptr(SCM scm_list) { return gnc_scm_list_to_glist(scm_list); } /******************************************************************** * gnc_glist_commodity_ptr_p ********************************************************************/ int gnc_glist_commodity_ptr_p(SCM list) { return gh_list_p(list); } /******************************************************************** * gnc_glist_price_ptr_to_scm ********************************************************************/ SCM gnc_glist_price_ptr_to_scm(GList * l) { static SCM price_type = SCM_UNDEFINED; SCM result_list; if(price_type == SCM_UNDEFINED) { price_type = gh_eval_str(""); /* don't really need this - types are bound globally anyway. */ if(price_type != SCM_UNDEFINED) scm_protect_object(price_type); } result_list = gnc_glist_to_scm_list(l, price_type); g_list_free(l); return result_list; } /******************************************************************** * gnc_scm_to_glist_price_ptr ********************************************************************/ GList * gnc_scm_to_glist_price_ptr(SCM scm_list) { return gnc_scm_list_to_glist(scm_list); } /******************************************************************** * gnc_glist_price_ptr_p ********************************************************************/ int gnc_glist_price_ptr_p(SCM list) { return gh_list_p(list); }