1 /********************************************************************\
2 * gnc-guile-utils.c -- basic guile extensions *
3 * Copyright (C) 2012 Geert Janssens *
4 * *
5 * This program is free software; you can redistribute it and/or *
6 * modify it under the terms of the GNU General Public License as *
7 * published by the Free Software Foundation; either version 2 of *
8 * the License, or (at your option) any later version. *
9 * *
10 * This program is distributed in the hope that it will be useful, *
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of *
12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *
13 * GNU General Public License for more details. *
14 * *
15 * You should have received a copy of the GNU General Public License*
16 * along with this program; if not, write to the Free Software *
17 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *
18 \********************************************************************/
19
20 #include <config.h>
21
22 #include <glib.h>
23 #include "swig-runtime.h"
24 #include <libguile.h>
25
26 #include "gnc-guile-utils.h"
27 #include "guile-mappings.h"
28
29
30 /********************************************************************\
31 * gnc_scm_to_utf8_string *
32 * returns the string representation of the scm string in *
33 * a newly allocated gchar * or NULL if it can't be retrieved. *
34 * *
35 * Args: symbol_value - the scm symbol *
36 * Returns: newly allocated gchar * or NULL, should be freed with *
37 * g_free by the caller *
38 \********************************************************************/
gnc_scm_to_utf8_string(SCM scm_string)39 gchar *gnc_scm_to_utf8_string(SCM scm_string)
40 {
41 if (scm_is_string (scm_string))
42 return scm_to_utf8_stringn(scm_string, NULL);
43
44 /* Unable to extract string from the symbol...*/
45 g_error ("bad value\n");
46 return NULL;
47 }
48
49
50 /********************************************************************\
51 * gnc_scm_to_locale_string *
52 * returns the string representation of the scm string in *
53 * a newly allocated gchar * or NULL if it can't be retrieved. *
54 * The string will be encoded in the current locale's encoding. *
55 * Note: this function should only be use to convert filenames or *
56 * strings from the environment. Or other strings that are in the *
57 * system locale. *
58 * *
59 * Args: symbol_value - the scm symbol *
60 * Returns: newly allocated gchar * or NULL, should be freed with *
61 * g_free by the caller *
62 \********************************************************************/
gnc_scm_to_locale_string(SCM scm_string)63 gchar *gnc_scm_to_locale_string(SCM scm_string)
64 {
65 if (scm_is_string (scm_string))
66 return scm_to_locale_string(scm_string);
67
68 /* Unable to extract string from the symbol...*/
69 g_error ("bad value\n");
70 return NULL;
71 }
72
73
74 /********************************************************************\
75 * gnc_scm_symbol_to_locale_string *
76 * returns the string representation of the scm symbol in *
77 * a newly allocated gchar * or NULL if it can't be retrieved. *
78 * *
79 * Args: symbol_value - the scm symbol *
80 * Returns: newly allocated gchar * or NULL, should be freed with *
81 * g_free by the caller *
82 \********************************************************************/
83 gchar *
gnc_scm_symbol_to_locale_string(SCM symbol_value)84 gnc_scm_symbol_to_locale_string(SCM symbol_value)
85 {
86
87 if (scm_is_symbol(symbol_value))
88 {
89 SCM string_value = scm_symbol_to_string (symbol_value);
90 if (scm_is_string (string_value))
91 return scm_to_utf8_string (string_value);
92 }
93
94 /* Unable to extract string from the symbol...*/
95 g_error ("bad value\n");
96 return NULL;
97 }
98
99
100 /********************************************************************\
101 * gnc_scm_call_1_to_string *
102 * returns the malloc'ed string returned by the guile function *
103 * or NULL if it can't be retrieved *
104 * *
105 * Args: func - the guile function to call *
106 * arg - the single function argument *
107 * Returns: g_malloc'ed char * or NULL must be freed with g_free *
108 \********************************************************************/
109 char *
gnc_scm_call_1_to_string(SCM func,SCM arg)110 gnc_scm_call_1_to_string(SCM func, SCM arg)
111 {
112 SCM value;
113
114 if (scm_is_procedure(func))
115 {
116 value = scm_call_1(func, arg);
117
118 if (scm_is_string(value))
119 {
120 return gnc_scm_to_utf8_string(value);
121 }
122 else
123 {
124 g_error ("bad value\n");
125 }
126 }
127 else
128 {
129 g_error ("not a procedure\n");
130 }
131
132 return NULL;
133 }
134
135
136 /********************************************************************\
137 * gnc_scm_call_1_symbol_to_string *
138 * returns the malloc'ed string returned by the guile function *
139 * or NULL if it can't be retrieved. The return value of the *
140 * function should be a symbol. *
141 * *
142 * Args: func - the guile function to call *
143 * arg - the single function argument *
144 * Returns: malloc'ed char * or NULL *
145 \********************************************************************/
146 char *
gnc_scm_call_1_symbol_to_string(SCM func,SCM arg)147 gnc_scm_call_1_symbol_to_string(SCM func, SCM arg)
148 {
149 SCM symbol_value;
150
151 if (scm_is_procedure(func))
152 {
153 symbol_value = scm_call_1(func, arg);
154 return gnc_scm_symbol_to_locale_string (symbol_value);
155 }
156 else
157 {
158 g_error ("not a procedure\n");
159 }
160
161 return NULL;
162 }
163
164
165 /********************************************************************\
166 * gnc_scm_call_1_to_procedure *
167 * returns the SCM handle to the procedure returned by the guile *
168 * function, or SCM_UNDEFINED if it couldn't be retrieved. *
169 * *
170 * Args: func - the guile function to call *
171 * arg - the single function argument *
172 * Returns: SCM function handle or SCM_UNDEFINED *
173 \********************************************************************/
174 SCM
gnc_scm_call_1_to_procedure(SCM func,SCM arg)175 gnc_scm_call_1_to_procedure(SCM func, SCM arg)
176 {
177 SCM value;
178
179 if (scm_is_procedure(func))
180 {
181 value = scm_call_1(func, arg);
182
183 if (scm_is_procedure(value))
184 return value;
185 else
186 {
187 g_error ("bad value\n");
188 }
189 }
190 else
191 {
192 g_error ("not a procedure\n");
193 }
194
195 return SCM_UNDEFINED;
196 }
197
198
199 /********************************************************************\
200 * gnc_scm_call_1_to_list *
201 * returns the SCM handle to the list returned by the guile *
202 * function, or SCM_UNDEFINED if it couldn't be retrieved. *
203 * *
204 * Args: func - the guile function to call *
205 * arg - the single function argument *
206 * Returns: SCM list handle or SCM_UNDEFINED *
207 \********************************************************************/
208 SCM
gnc_scm_call_1_to_list(SCM func,SCM arg)209 gnc_scm_call_1_to_list(SCM func, SCM arg)
210 {
211 SCM value;
212
213 if (scm_is_procedure(func))
214 {
215 value = scm_call_1(func, arg);
216
217 if (scm_is_list(value))
218 return value;
219 else
220 {
221 g_error ("bad value\n");
222 }
223 }
224 else
225 {
226 g_error ("not a procedure\n");
227 }
228
229 return SCM_UNDEFINED;
230 }
231
232
233 /********************************************************************\
234 * gnc_scm_call_1_to_vector *
235 * returns the SCM handle to the vector returned by the guile *
236 * function, or SCM_UNDEFINED if it couldn't be retrieved. *
237 * *
238 * Args: func - the guile function to call *
239 * arg - the single function argument *
240 * Returns: SCM vector handle or SCM_UNDEFINED *
241 \********************************************************************/
242 SCM
gnc_scm_call_1_to_vector(SCM func,SCM arg)243 gnc_scm_call_1_to_vector(SCM func, SCM arg)
244 {
245 SCM value;
246
247 if (scm_is_procedure(func))
248 {
249 value = scm_call_1(func, arg);
250
251 if (scm_is_vector(value))
252 return value;
253 else
254 {
255 g_error ("bad value\n");
256 }
257 }
258 else
259 {
260 g_error ("not a procedure\n");
261 }
262
263 return SCM_UNDEFINED;
264 }
265
266
267 /* Clean up a scheme options string for use in a key/value file.
268 * This function removes all full line comments, removes all blank
269 * lines, and removes all leading/trailing white space. */
gnc_scm_strip_comments(SCM scm_text)270 gchar *gnc_scm_strip_comments (SCM scm_text)
271 {
272 gchar *raw_text, *text, **splits;
273 gint i, j;
274
275 raw_text = gnc_scm_to_utf8_string (scm_text);
276 splits = g_strsplit(raw_text, "\n", -1);
277 for (i = j = 0; splits[i]; i++)
278 {
279 if ((splits[i][0] == ';') || (splits[i][0] == '\0'))
280 {
281 g_free(splits[i]);
282 continue;
283 }
284 splits[j++] = splits [i];
285 }
286 splits[j] = NULL;
287
288 text = g_strjoinv(" ", splits);
289 g_free (raw_text);
290 g_strfreev(splits);
291 return text;
292 }
293