SCM
abort_test (SCM name, char *exception)
{
(*env)->ExceptionClear (env);
return gh_list (name,
gh_symbol2scm ("ERROR"),
gh_str02scm (exception),
SCM_UNDEFINED);
}
/**
** Default title-screen.
**
** @param title SCM title. (nil reports only)
**
** @return Current title screen.
*/
local SCM CclTitleScreen(SCM title)
{
if( !gh_null_p(title) ) {
if( TitleScreen ) {
free(TitleScreen);
TitleScreen=NULL;
}
TitleScreen=gh_scm2newstr(title,NULL);
} else {
title=gh_str02scm(TitleScreen);
}
return title;
}
SCM
gconf_value_to_scm(GConfValue* val)
{
SCM retval = SCM_EOL;
if (val == NULL)
return SCM_EOL;
switch (val->type)
{
case GCONF_VALUE_INVALID:
/* EOL */
break;
case GCONF_VALUE_STRING:
retval = gh_str02scm(gconf_value_get_string(val));
break;
case GCONF_VALUE_INT:
retval = gh_int2scm(gconf_value_get_int(val));
break;
case GCONF_VALUE_FLOAT:
retval = gh_double2scm(gconf_value_get_float(val));
break;
case GCONF_VALUE_BOOL:
retval = gh_bool2scm(gconf_value_get_bool(val));
break;
case GCONF_VALUE_SCHEMA:
/* FIXME this is more complicated, we need a smob or something */
break;
case GCONF_VALUE_LIST:
/* FIXME This is complicated too... */
break;
case GCONF_VALUE_PAIR:
retval = gh_cons(gconf_value_to_scm(gconf_value_get_car(val)),
gconf_value_to_scm(gconf_value_get_cdr(val)));
break;
default:
g_warning("Unhandled type in %s", G_STRFUNC);
break;
}
return retval;
}
SCM
handle_test_exception (jobject test_name_obj)
{
jthrowable throwable;
jclass object_class;
jobject err_msg_obj;
char *err_msg, *test_name;
const char *utf;
SCM result;
jboolean is_copy;
static jmethodID obj_toString_mid = NULL;
throwable = (*env)->ExceptionOccurred (env);
(*env)->ExceptionClear (env);
if (obj_toString_mid == NULL)
obj_toString_mid = (*env)->GetMethodID (env,
(*env)->FindClass (env,
"java/lang/Object"),
"toString",
"()Ljava/lang/String;");
err_msg_obj = (*env)->CallObjectMethod (env, throwable, obj_toString_mid);
utf = (*env)->GetStringUTFChars (env, err_msg_obj, &is_copy);
err_msg = strdup (utf);
(*env)->ReleaseStringUTFChars (env, err_msg_obj, utf);
utf = (*env)->GetStringUTFChars (env, test_name_obj, &is_copy);
test_name = strdup (utf);
(*env)->ReleaseStringUTFChars (env, test_name_obj, utf);
result = abort_test (gh_str02scm (test_name), err_msg);
free (err_msg);
free (test_name);
return result;
}
SCM
perform_test (SCM clazz_scm_name)
{
char *clazz_name, *test_name, *result_name, *msg;
const char *utf;
jclass clazz;
jmethodID mid;
jobject test_obj, result_obj, test_name_obj, result_name_obj, msg_obj;
jboolean is_copy;
SCM scm_test_name, scm_result_name, scm_result_msg;
clazz_name = gh_scm2newstr (clazz_scm_name, NULL);
clazz = (*env)->FindClass (env, clazz_name);
if (clazz == NULL)
{
SCM clazz_err = gh_str02scm (clazz_name);
free (clazz_name);
return abort_test (clazz_err, "Unable to find class");
}
mid = (*env)->GetMethodID (env, clazz, "<init>", "()V");
test_obj = (*env)->NewObject (env, clazz, mid);
if ((*env)->IsInstanceOf (env, test_obj, test_class) == JNI_FALSE)
{
SCM clazz_err = gh_str02scm (clazz_name);
free (clazz_name);
return abort_test (clazz_err, "Not an instanceof gnu.test.Test");
}
free (clazz_name);
/* Call all the Java testing methods */
test_name_obj = (*env)->CallObjectMethod (env, test_obj, test_name_mid);
result_obj = (*env)->CallObjectMethod (env, test_obj, test_mid);
/* Handle an exception if one occurred */
if ((*env)->ExceptionOccurred (env))
return handle_test_exception (test_name_obj);
result_name_obj = (*env)->CallObjectMethod (env, result_obj,
result_name_mid);
msg_obj = (*env)->CallObjectMethod (env, result_obj, result_msg_mid);
/* Grab all the C result messages */
utf = (*env)->GetStringUTFChars (env, test_name_obj, &is_copy);
test_name = strdup (utf);
(*env)->ReleaseStringUTFChars (env, test_name_obj, utf);
utf = (*env)->GetStringUTFChars (env, result_name_obj, &is_copy);
result_name = strdup (utf);
(*env)->ReleaseStringUTFChars (env, result_name_obj, utf);
utf = (*env)->GetStringUTFChars (env, msg_obj, &is_copy);
msg = strdup (utf);
(*env)->ReleaseStringUTFChars (env, msg_obj, utf);
/* Convert the C result messages to Scheme */
scm_test_name = gh_str02scm (test_name);
scm_result_name = gh_symbol2scm (result_name);
scm_result_msg = gh_str02scm (msg);
/* Free up the C result messages */
free (test_name);
free (result_name);
free (msg);
return gh_list (scm_test_name,
scm_result_name,
scm_result_msg,
SCM_UNDEFINED);
}
/**
** Clone library path.
**
** @return Current clone libray path.
*/
local SCM CclCloneLibraryPath(void)
{
return gh_str02scm(CloneLibPath);
}
/**
** Clone library path.
**
** @return Current clone libray path.
*/
local SCM CclCloneLibraryPath(void)
{
return gh_str02scm(CLONE_LIB_PATH);
}