/* We assume that data is actually a char**. The way we return results
* from this function is to malloc a fresh string, and store it in
* this pointer. It is the caller's responsibility to do something
* smart with this freshly allocated storage. the caller can determine
* whether there was an error by initializing the char* passed in to
* NULL. If there is an error, the char string will not be NULL on
* return. */
static SCM
gfec_catcher(void *data, SCM tag, SCM throw_args)
{
SCM func;
SCM result;
const char *msg = NULL;
func = scm_c_eval_string("gnc:error->string");
if (scm_is_procedure(func))
{
result = scm_call_2(func, tag, throw_args);
if (scm_is_string(result))
{
char * str;
scm_dynwind_begin (0);
str = scm_to_locale_string (result);
msg = g_strdup (str);
scm_dynwind_free (str);
scm_dynwind_end ();
}
}
if (msg == NULL)
{
msg = "Error running guile function.";
}
*(char**)data = strdup(msg);
return SCM_UNDEFINED;
}
SCM
gfec_eval_string(const char *str, gfec_error_handler error_handler)
{
SCM result = SCM_UNDEFINED;
SCM func = scm_c_eval_string("gnc:eval-string-with-error-handling");
if (scm_is_procedure(func))
{
char *err_msg = NULL;
SCM call_result, error = SCM_UNDEFINED;
call_result = scm_call_1 (func, scm_from_utf8_string (str));
error = scm_list_ref (call_result, scm_from_uint (1));
if (scm_is_true (error))
err_msg = gnc_scm_to_utf8_string (error);
else
result = scm_list_ref (call_result, scm_from_uint (0));
if (err_msg != NULL)
{
if (error_handler)
error_handler (err_msg);
free(err_msg);
}
}
return result;
}
static void
run_tests (void)
{
Query *q;
SCM val2str;
int i;
val2str = scm_c_eval_string ("gnc:value->string");
g_return_if_fail (scm_is_procedure (val2str));
for (i = 0; i < 1000; i++)
{
q = get_random_query ();
test_query (q, val2str);
qof_query_destroy (q);
fflush(stdout);
}
{
q = get_random_query ();
test_query (q, val2str);
qof_query_destroy (q);
fflush(stdout);
}
}
/********************************************************************\
* gnc_guile_call1_to_string *
* returns the malloc'ed string returned by the guile function *
* or NULL if it can't be retrieved *
* *
* Args: func - the guile function to call *
* arg - the single function argument *
* Returns: g_malloc'ed char * or NULL *
\********************************************************************/
char *
gnc_guile_call1_to_string(SCM func, SCM arg)
{
SCM value;
if (scm_is_procedure(func))
{
value = scm_call_1(func, arg);
if (scm_is_string(value))
{
return gnc_scm_to_locale_string(value);
}
else
{
PERR("bad value\n");
}
}
else
{
PERR("not a procedure\n");
}
return NULL;
}
SCM
gfec_apply(SCM proc, SCM arglist, gfec_error_handler error_handler)
{
SCM result = SCM_UNDEFINED;
SCM func = scm_c_eval_string("gnc:apply-with-error-handling");
if (scm_is_procedure(func))
{
char *err_msg = NULL;
SCM call_result, error;
call_result = scm_call_2 (func, proc, arglist);
error = scm_list_ref (call_result, scm_from_uint (1));
if (scm_is_true (error))
err_msg = gnc_scm_to_utf8_string (error);
else
result = scm_list_ref (call_result, scm_from_uint (0));
if (err_msg != NULL)
{
if (error_handler)
error_handler (err_msg);
free(err_msg);
}
}
return result;
}
static void
dirty_same_stylesheet(gpointer key, gpointer val, gpointer data)
{
SCM dirty_ss = data;
SCM rep_ss = NULL;
SCM report = val;
SCM func = NULL;
func = scm_c_eval_string("gnc:report-stylesheet");
if (scm_is_procedure(func))
rep_ss = scm_call_1(func, report);
else
return;
if (scm_is_true(scm_eq_p(rep_ss, dirty_ss)))
{
func = scm_c_eval_string("gnc:report-set-dirty?!");
/* This makes _me_ feel dirty! */
if (scm_is_procedure(func))
scm_call_2(func, report, SCM_BOOL_T);
}
}
/********************************************************************\
* gnc_guile_call1_to_procedure *
* returns the SCM handle to the procedure returned by the guile *
* function, or SCM_UNDEFINED if it couldn't be retrieved. *
* *
* Args: func - the guile function to call *
* arg - the single function argument *
* Returns: SCM function handle or SCM_UNDEFINED *
\********************************************************************/
SCM
gnc_guile_call1_to_procedure(SCM func, SCM arg)
{
SCM value;
if (scm_is_procedure(func))
{
value = scm_call_1(func, arg);
if (scm_is_procedure(value))
return value;
else
{
PERR("bad value\n");
}
}
else
{
PERR("not a procedure\n");
}
return SCM_UNDEFINED;
}
/********************************************************************\
* gnc_copy_split_scm_onto_split *
* copies a scheme representation of a split onto an actual split.*
* *
* Args: split_scm - the scheme representation of a split *
* split - the split to copy onto *
* Returns: Nothing *
\********************************************************************/
void
gnc_copy_split_scm_onto_split(SCM split_scm, Split *split,
QofBook * book)
{
static swig_type_info *split_type = NULL;
SCM result;
SCM func;
SCM arg;
if (split_scm == SCM_UNDEFINED)
return;
if (split == NULL)
return;
g_return_if_fail (book);
func = scm_c_eval_string("gnc:split-scm?");
if (!scm_is_procedure(func))
return;
result = scm_call_1(func, split_scm);
if (!scm_is_true(result))
return;
func = scm_c_eval_string("gnc:split-scm-onto-split");
if (!scm_is_procedure(func))
return;
if (!split_type)
split_type = SWIG_TypeQuery("_p_Split");
arg = SWIG_NewPointerObj(split, split_type, 0);
scm_call_3(func, split_scm, arg, gnc_book_to_scm (book));
}
static void
run_tests (int count)
{
Query *q;
SCM val2str;
int i;
val2str = scm_c_eval_string ("gnc:value->string");
g_return_if_fail (scm_is_procedure (val2str));
for (i = 0; i < count; i++)
{
q = get_random_query ();
test_query (q, val2str);
qof_query_destroy (q);
}
success ("");
}
SCM
gfec_eval_string(const char *str, gfec_error_handler error_handler)
{
SCM result = SCM_UNDEFINED;
SCM func = scm_c_eval_string("gnc:eval-string-with-error-handling");
if (scm_is_procedure(func))
{
char *err_msg = NULL;
SCM call_result, error = SCM_UNDEFINED;
/* Deal with the possibility that scm_from_utf8_string will
* throw, falling back to scm_from_locale_string. If that fails, log a
* warning and punt.
*/
SCM scm_string = scm_internal_catch(SCM_BOOL_T,
gfec_string_from_utf8, (void*)str,
gfec_string_inner_handler,
(void*)str);
if (!scm_string)
{
error_handler("Contents could not be interpreted as UTF-8 or the current locale/codepage.");
return result;
}
call_result = scm_call_1 (func, scm_string);
error = scm_list_ref (call_result, scm_from_uint (1));
if (scm_is_true (error))
err_msg = gnc_scm_to_utf8_string (error);
else
result = scm_list_ref (call_result, scm_from_uint (0));
if (err_msg != NULL)
{
if (error_handler)
error_handler (err_msg);
free(err_msg);
}
}
return result;
}
/********************************************************************\
* gnc_copy_split *
* returns a scheme representation of a split. If the split is *
* NULL, SCM_UNDEFINED is returned. *
* *
* Args: split - the split to copy *
* use_cut_semantics - if TRUE, copy is for a 'cut' operation *
* Returns: SCM representation of split or SCM_UNDEFINED *
\********************************************************************/
SCM
gnc_copy_split(Split *split, gboolean use_cut_semantics)
{
static swig_type_info *split_type = NULL;
SCM func;
SCM arg;
if (split == NULL)
return SCM_UNDEFINED;
func = scm_c_eval_string("gnc:split->split-scm");
if (!scm_is_procedure(func))
return SCM_UNDEFINED;
if (!split_type)
split_type = SWIG_TypeQuery("_p_Split");
arg = SWIG_NewPointerObj(split, split_type, 0);
return scm_call_2(func, arg, SCM_BOOL(use_cut_semantics));
}
/********************************************************************\
* gnc_copy_trans *
* returns a scheme representation of a transaction. If the *
* transaction is NULL, SCM_UNDEFINED is returned. *
* *
* Args: trans - the transaction to copy *
* use_cut_semantics - if TRUE, copy is for a 'cut' operation *
* Returns: SCM representation of transaction or SCM_UNDEFINED *
\********************************************************************/
SCM
gnc_copy_trans(Transaction *trans, gboolean use_cut_semantics)
{
static swig_type_info *trans_type = NULL;
SCM func;
SCM arg;
if (trans == NULL)
return SCM_UNDEFINED;
func = scm_c_eval_string("gnc:transaction->transaction-scm");
if (!scm_is_procedure(func))
return SCM_UNDEFINED;
if (!trans_type)
trans_type = SWIG_TypeQuery("_p_Transaction");
arg = SWIG_NewPointerObj(trans, trans_type, 0);
return scm_call_2(func, arg, SCM_BOOL(use_cut_semantics));
}
/********************************************************************\
* gnc_guile_call1_symbol_to_string *
* returns the malloc'ed string returned by the guile function *
* or NULL if it can't be retrieved. The return value of the *
* function should be a symbol. *
* *
* Args: func - the guile function to call *
* arg - the single function argument *
* Returns: malloc'ed char * or NULL *
\********************************************************************/
char *
gnc_guile_call1_symbol_to_string(SCM func, SCM arg)
{
SCM value;
if (scm_is_procedure(func))
{
value = scm_call_1(func, arg);
if (scm_is_symbol(value))
return g_strdup(SCM_SYMBOL_CHARS(value));
else
{
PERR("bad value\n");
}
}
else
{
PERR("not a procedure\n");
}
return NULL;
}
static int build_owner_report (GncOwner *owner, Account *acc)
{
SCM args;
SCM func;
SCM arg;
g_return_val_if_fail (owner, -1);
args = SCM_EOL;
func = scm_c_eval_string ("gnc:owner-report-create");
g_return_val_if_fail (scm_is_procedure (func), -1);
if (acc)
{
swig_type_info * qtype = SWIG_TypeQuery("_p_Account");
g_return_val_if_fail (qtype, -1);
arg = SWIG_NewPointerObj(acc, qtype, 0);
g_return_val_if_fail (arg != SCM_UNDEFINED, -1);
args = scm_cons (arg, args);
}
else
{
args = scm_cons (SCM_BOOL_F, args);
}
arg = SWIG_NewPointerObj(owner, SWIG_TypeQuery("_p__gncOwner"), 0);
g_return_val_if_fail (arg != SCM_UNDEFINED, -1);
args = scm_cons (arg, args);
/* Apply the function to the args */
arg = scm_apply (func, args, SCM_EOL);
g_return_val_if_fail (scm_is_exact (arg), -1);
return scm_to_int (arg);
}
void
gnc_prices_dialog_get_quotes_clicked (GtkWidget *widget, gpointer data)
{
PricesDialog *pdb_dialog = data;
SCM quotes_func;
SCM book_scm;
SCM scm_window;
ENTER(" ");
quotes_func = scm_c_eval_string ("gnc:book-add-quotes");
if (!scm_is_procedure (quotes_func))
{
LEAVE(" no procedure");
return;
}
book_scm = gnc_book_to_scm (pdb_dialog->book);
if (scm_is_true (scm_not (book_scm)))
{
LEAVE("no book");
return;
}
scm_window = SWIG_NewPointerObj(pdb_dialog->dialog,
SWIG_TypeQuery("_p_GtkWidget"), 0);
gnc_set_busy_cursor (NULL, TRUE);
scm_call_2 (quotes_func, scm_window, book_scm);
gnc_unset_busy_cursor (NULL);
/* Without this, the summary bar on the accounts tab
* won't reflect the new prices (bug #522095). */
gnc_gui_refresh_all ();
LEAVE(" ");
}
static int
build_aging_report (GncOwnerType owner_type)
{
gchar *report_name = NULL;
gchar *report_title = NULL;
SCM args;
SCM func;
SCM arg;
args = SCM_EOL;
switch (owner_type)
{
case GNC_OWNER_NONE :
case GNC_OWNER_UNDEFINED :
case GNC_OWNER_EMPLOYEE :
case GNC_OWNER_JOB :
{
return -1;
}
case GNC_OWNER_VENDOR :
{
report_name = "gnc:payables-report-create";
report_title = _("Vendor Listing");
break;
}
case GNC_OWNER_CUSTOMER :
{
report_name = "gnc:receivables-report-create";
report_title = _("Customer Listing");
break;
}
}
/* Find report generator function in guile */
func = scm_c_eval_string (report_name);
g_return_val_if_fail (scm_is_procedure (func), -1);
/* Option Show zero's ? - Yes for the listing report */
arg = SCM_BOOL_T;
args = scm_cons (arg, args);
g_return_val_if_fail (arg != SCM_UNDEFINED, -1);
/* Option Report title */
arg = scm_from_locale_string (report_title);
args = scm_cons (arg, args);
/* Option Account - Using False to select default account
*
* XXX I'm not sure if it would make sense to use another
* account than default */
arg = SCM_BOOL_F;
args = scm_cons (arg, args);
g_return_val_if_fail (arg != SCM_UNDEFINED, -1);
/* Apply the function to the args */
arg = scm_apply (func, args, SCM_EOL);
g_return_val_if_fail (scm_is_exact (arg), -1);
return scm_to_int (arg);
}
static
void*
func_op(const char *fname, int argc, void **argv)
{
SCM scmFn, scmArgs, scmTmp;
int i;
var_store *vs;
gchar *str;
gnc_numeric n, *result;
GString *realFnName;
realFnName = g_string_sized_new( strlen(fname) + 5 );
g_string_printf( realFnName, "gnc:%s", fname );
scmFn = scm_internal_catch(SCM_BOOL_T,
(scm_t_catch_body)scm_c_eval_string, realFnName->str,
scm_handle_by_message_noexit, NULL);
g_string_free( realFnName, TRUE );
if (!scm_is_procedure(scmFn))
{
/* FIXME: handle errors correctly. */
printf( "gnc:\"%s\" is not a scm procedure\n", fname );
return NULL;
}
scmArgs = scm_listify( SCM_UNDEFINED );
for ( i = 0; i < argc; i++ )
{
/* cons together back-to-front. */
vs = (var_store*)argv[argc - i - 1];
switch ( vs->type )
{
case VST_NUMERIC:
n = *(gnc_numeric*)(vs->value);
scmTmp = scm_make_real( gnc_numeric_to_double( n ) );
break;
case VST_STRING:
str = (char*)(vs->value);
scmTmp = scm_mem2string( str, strlen(str) );
break;
default:
/* FIXME: error */
printf( "argument %d not a numeric or string [type = %d]\n",
i, vs->type );
return NULL;
break; /* notreached */
}
scmArgs = scm_cons( scmTmp, scmArgs );
}
//scmTmp = scm_apply(scmFn, scmArgs , SCM_EOL);
scmTmp = gfec_apply(scmFn, scmArgs, _exception_handler);
if (_function_evaluation_error_msg != NULL)
{
PERR("function eval error: [%s]\n", _function_evaluation_error_msg);
_function_evaluation_error_msg = NULL;
return NULL;
}
result = g_new0( gnc_numeric, 1 );
*result = double_to_gnc_numeric( scm_num2dbl(scmTmp, G_STRFUNC),
GNC_DENOM_AUTO,
GNC_HOW_DENOM_SIGFIGS(6) | GNC_HOW_RND_ROUND );
/* FIXME: cleanup scmArgs = scm_list, cons'ed cells? */
return (void*)result;
}
/********************************************************************\
* gnc_copy_trans_scm_onto_trans_swap_accounts *
* copies a scheme representation of a transaction onto *
* an actual transaction. If guid_1 and guid_2 are not NULL, *
* the account guids of the splits are swapped accordingly. *
* *
* Args: trans_scm - the scheme representation of a transaction *
* trans - the transaction to copy onto *
* guid_1 - account guid to swap with guid_2 *
* guid_2 - account guid to swap with guid_1 *
* do_commit - whether to commit the edits *
* Returns: Nothing *
\********************************************************************/
void
gnc_copy_trans_scm_onto_trans_swap_accounts(SCM trans_scm,
Transaction *trans,
const GncGUID *guid_1,
const GncGUID *guid_2,
gboolean do_commit,
QofBook *book)
{
static swig_type_info *trans_type = NULL;
SCM result;
SCM func;
SCM arg;
if (trans_scm == SCM_UNDEFINED)
return;
if (trans == NULL)
return;
g_return_if_fail (book);
func = scm_c_eval_string("gnc:transaction-scm?");
if (!scm_is_procedure(func))
return;
result = scm_call_1(func, trans_scm);
if (!scm_is_true(result))
return;
func = scm_c_eval_string("gnc:transaction-scm-onto-transaction");
if (!scm_is_procedure(func))
return;
if (!trans_type)
trans_type = SWIG_TypeQuery("_p_Transaction");
arg = SWIG_NewPointerObj(trans, trans_type, 0);
if ((guid_1 == NULL) || (guid_2 == NULL))
{
SCM args = SCM_EOL;
SCM commit;
commit = SCM_BOOL(do_commit);
args = scm_cons(gnc_book_to_scm (book), args);
args = scm_cons(commit, args);
args = scm_cons(SCM_EOL, args);
args = scm_cons(arg, args);
args = scm_cons(trans_scm, args);
scm_apply(func, args, SCM_EOL);
}
else
{
gchar guidstr[GUID_ENCODING_LENGTH+1];
SCM from, to;
SCM map = SCM_EOL;
SCM args = SCM_EOL;
SCM commit;
args = scm_cons(gnc_book_to_scm (book), args);
commit = SCM_BOOL(do_commit);
args = scm_cons(commit, args);
guid_to_string_buff(guid_1, guidstr);
from = scm_from_utf8_string(guidstr);
guid_to_string_buff(guid_2, guidstr);
to = scm_from_utf8_string(guidstr);
map = scm_cons(scm_cons(from, to), map);
map = scm_cons(scm_cons(to, from), map);
args = scm_cons(map, args);
args = scm_cons(arg, args);
args = scm_cons(trans_scm, args);
scm_apply(func, args, SCM_EOL);
}
}