mirror of
https://github.com/Gnucash/gnucash.git
synced 2025-02-25 18:55:30 -06:00
1238b9d8cd
This will avoid a ninja-build from picking up a config.h generated by the autotools build (in the root build directory). Picking up the wrong config.h may lead to all kinds of subtle issues if the autotools run was done with different options than the cmake run.
335 lines
11 KiB
C
335 lines
11 KiB
C
/********************************************************************\
|
|
* gnc-guile-utils.c -- basic guile extensions *
|
|
* Copyright (C) 2012 Geert Janssens *
|
|
* *
|
|
* 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, write to the Free Software *
|
|
* Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *
|
|
\********************************************************************/
|
|
|
|
#include <config.h>
|
|
|
|
#include <glib.h>
|
|
#include "swig-runtime.h"
|
|
#include <libguile.h>
|
|
|
|
#include "gnc-guile-utils.h"
|
|
#include "guile-mappings.h"
|
|
|
|
|
|
/********************************************************************\
|
|
* gnc_scm_to_utf8_string *
|
|
* returns the string representation of the scm string in *
|
|
* a newly allocated gchar * or NULL if it can't be retrieved. *
|
|
* *
|
|
* Args: symbol_value - the scm symbol *
|
|
* Returns: newly allocated gchar * or NULL, should be freed with *
|
|
* g_free by the caller *
|
|
\********************************************************************/
|
|
gchar *gnc_scm_to_utf8_string(SCM scm_string)
|
|
{
|
|
if (scm_is_string (scm_string))
|
|
{
|
|
gchar* s;
|
|
char * str;
|
|
|
|
str = scm_to_utf8_string(scm_string);
|
|
s = g_strdup(str);
|
|
free (str);
|
|
return s;
|
|
}
|
|
|
|
/* Unable to extract string from the symbol...*/
|
|
g_error ("bad value\n");
|
|
return NULL;
|
|
}
|
|
|
|
|
|
/********************************************************************\
|
|
* gnc_scm_to_locale_string *
|
|
* returns the string representation of the scm string in *
|
|
* a newly allocated gchar * or NULL if it can't be retrieved. *
|
|
* The string will be encoded in the current locale's encoding. *
|
|
* Note: this function should only be use to convert filenames or *
|
|
* strings from the environment. Or other strings that are in the *
|
|
* system locale. *
|
|
* *
|
|
* Args: symbol_value - the scm symbol *
|
|
* Returns: newly allocated gchar * or NULL, should be freed with *
|
|
* g_free by the caller *
|
|
\********************************************************************/
|
|
gchar *gnc_scm_to_locale_string(SCM scm_string)
|
|
{
|
|
if (scm_is_string (scm_string))
|
|
{
|
|
gchar* s;
|
|
char * str;
|
|
|
|
str = scm_to_locale_string(scm_string);
|
|
s = g_strdup(str);
|
|
free (str);
|
|
return s;
|
|
}
|
|
|
|
/* Unable to extract string from the symbol...*/
|
|
g_error ("bad value\n");
|
|
return NULL;
|
|
}
|
|
|
|
|
|
/********************************************************************\
|
|
* gnc_scm_symbol_to_locale_string *
|
|
* returns the string representation of the scm symbol in *
|
|
* a newly allocated gchar * or NULL if it can't be retrieved. *
|
|
* *
|
|
* Args: symbol_value - the scm symbol *
|
|
* Returns: newly allocated gchar * or NULL, should be freed with *
|
|
* g_free by the caller *
|
|
\********************************************************************/
|
|
gchar *
|
|
gnc_scm_symbol_to_locale_string(SCM symbol_value)
|
|
{
|
|
|
|
if (scm_is_symbol(symbol_value))
|
|
{
|
|
SCM string_value = scm_symbol_to_string (symbol_value);
|
|
if (scm_is_string (string_value))
|
|
{
|
|
char *tmp = scm_to_utf8_string (string_value);
|
|
gchar *str = g_strdup (tmp);
|
|
free (tmp);
|
|
return str;
|
|
}
|
|
}
|
|
|
|
/* Unable to extract string from the symbol...*/
|
|
g_error ("bad value\n");
|
|
return NULL;
|
|
}
|
|
|
|
|
|
/********************************************************************\
|
|
* gnc_scm_call_1_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 must be freed with g_free *
|
|
\********************************************************************/
|
|
char *
|
|
gnc_scm_call_1_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_utf8_string(value);
|
|
}
|
|
else
|
|
{
|
|
g_error ("bad value\n");
|
|
}
|
|
}
|
|
else
|
|
{
|
|
g_error ("not a procedure\n");
|
|
}
|
|
|
|
return NULL;
|
|
}
|
|
|
|
|
|
/********************************************************************\
|
|
* gnc_scm_call_1_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_scm_call_1_symbol_to_string(SCM func, SCM arg)
|
|
{
|
|
SCM symbol_value;
|
|
|
|
if (scm_is_procedure(func))
|
|
{
|
|
symbol_value = scm_call_1(func, arg);
|
|
return gnc_scm_symbol_to_locale_string (symbol_value);
|
|
}
|
|
else
|
|
{
|
|
g_error ("not a procedure\n");
|
|
}
|
|
|
|
return NULL;
|
|
}
|
|
|
|
|
|
/********************************************************************\
|
|
* gnc_scm_call_1_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_scm_call_1_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
|
|
{
|
|
g_error ("bad value\n");
|
|
}
|
|
}
|
|
else
|
|
{
|
|
g_error ("not a procedure\n");
|
|
}
|
|
|
|
return SCM_UNDEFINED;
|
|
}
|
|
|
|
|
|
/********************************************************************\
|
|
* gnc_scm_call_1_to_list *
|
|
* returns the SCM handle to the list 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 list handle or SCM_UNDEFINED *
|
|
\********************************************************************/
|
|
SCM
|
|
gnc_scm_call_1_to_list(SCM func, SCM arg)
|
|
{
|
|
SCM value;
|
|
|
|
if (scm_is_procedure(func))
|
|
{
|
|
value = scm_call_1(func, arg);
|
|
|
|
if (scm_is_list(value))
|
|
return value;
|
|
else
|
|
{
|
|
g_error ("bad value\n");
|
|
}
|
|
}
|
|
else
|
|
{
|
|
g_error ("not a procedure\n");
|
|
}
|
|
|
|
return SCM_UNDEFINED;
|
|
}
|
|
|
|
|
|
/********************************************************************\
|
|
* gnc_scm_call_1_to_vector *
|
|
* returns the SCM handle to the vector 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 vector handle or SCM_UNDEFINED *
|
|
\********************************************************************/
|
|
SCM
|
|
gnc_scm_call_1_to_vector(SCM func, SCM arg)
|
|
{
|
|
SCM value;
|
|
|
|
if (scm_is_procedure(func))
|
|
{
|
|
value = scm_call_1(func, arg);
|
|
|
|
if (scm_is_vector(value))
|
|
return value;
|
|
else
|
|
{
|
|
g_error ("bad value\n");
|
|
}
|
|
}
|
|
else
|
|
{
|
|
g_error ("not a procedure\n");
|
|
}
|
|
|
|
return SCM_UNDEFINED;
|
|
}
|
|
|
|
|
|
/* Clean up a scheme options string for use in a key/value file.
|
|
* This function removes all full line comments, removes all blank
|
|
* lines, and removes all leading/trailing white space. */
|
|
gchar *gnc_scm_strip_comments (SCM scm_text)
|
|
{
|
|
gchar *raw_text, *text, **splits;
|
|
gint i, j;
|
|
|
|
raw_text = gnc_scm_to_utf8_string (scm_text);
|
|
splits = g_strsplit(raw_text, "\n", -1);
|
|
for (i = j = 0; splits[i]; i++)
|
|
{
|
|
gchar *haystack, *needle;
|
|
if ((splits[i][0] == ';') || (splits[i][0] == '\0'))
|
|
{
|
|
g_free(splits[i]);
|
|
continue;
|
|
}
|
|
|
|
/* Work around a bug in guile 1.8 that escapes spaces
|
|
* in a symbol printed on a string port. We don't
|
|
* want this, because this string can't be properly
|
|
* converted back into a symbol later on. */
|
|
|
|
haystack = splits [i];
|
|
needle = g_strstr_len (haystack, -1, "\\ ");
|
|
while (needle)
|
|
{
|
|
gchar *new_haystack = NULL;
|
|
gsize prefix_size = needle - haystack;
|
|
gchar *prefix = g_strndup (haystack, prefix_size);
|
|
needle++;
|
|
new_haystack = g_strconcat (prefix, needle, NULL);
|
|
g_free (prefix);
|
|
g_free (haystack);
|
|
haystack = new_haystack;
|
|
needle = g_strstr_len (haystack, -1, "\\ ");
|
|
}
|
|
splits[j++] = haystack;
|
|
}
|
|
splits[j] = NULL;
|
|
|
|
text = g_strjoinv(" ", splits);
|
|
g_free (raw_text);
|
|
g_strfreev(splits);
|
|
return text;
|
|
}
|