/*! \todo Finish function documentation!!!
* \brief
* \par Function Description
*
*/
SCM g_funcs_filesel(SCM scm_msg, SCM scm_templ, SCM scm_flags)
{
int c_flags;
char *r, *msg, *templ;
SCM v;
SCM_ASSERT (scm_is_string (scm_msg), scm_msg,
SCM_ARG1, "gschem-filesel");
SCM_ASSERT (scm_is_string (scm_templ), scm_templ,
SCM_ARG2, "gschem-filesel");
/*! \bug FIXME -- figure out the magic SCM_ASSERT for the flags */
/*! \bug FIXME -- how to deal with conflicting flags?
* Should I throw a scheme error? Just deal in the c code?
*/
for (c_flags = 0; scm_is_pair (scm_flags); scm_flags = SCM_CDR (scm_flags)) {
char *flag;
SCM scm_flag = SCM_CAR (scm_flags);
flag = scm_to_utf8_string (scm_flag);
if (strcmp (flag, "may_exist") == 0) {
c_flags |= FSB_MAY_EXIST;
} else if (strcmp (flag, "must_exist") == 0) {
c_flags |= FSB_MUST_EXIST;
} else if (strcmp (flag, "must_not_exist") == 0) {
c_flags |= FSB_SHOULD_NOT_EXIST;
} else if (strcmp (flag, "save") == 0) {
c_flags |= FSB_SAVE;
} else if (strcmp (flag, "open") == 0) {
c_flags |= FSB_LOAD;
} else {
free(flag);
scm_wrong_type_arg ("gschem-filesel", SCM_ARG3, scm_flag);
}
free(flag);
}
msg = scm_to_utf8_string (scm_msg);
templ = scm_to_utf8_string (scm_templ);
r = generic_filesel_dialog (msg, templ, c_flags);
free(msg);
free(templ);
v = scm_from_utf8_string (r);
g_free (r);
return v;
}
SCM g_get_package_attribute(SCM scm_uref, SCM scm_wanted_attrib)
{
SCM scm_return_value;
NETLIST *nl_current;
char *uref;
char *wanted_attrib;
char *return_value = NULL;
SCM_ASSERT(scm_is_string (scm_uref),
scm_uref, SCM_ARG1, "gnetlist:get-package-attribute");
SCM_ASSERT(scm_is_string (scm_wanted_attrib),
scm_wanted_attrib, SCM_ARG2, "gnetlist:get-package-attribute");
uref = SCM_STRING_CHARS (scm_uref);
wanted_attrib = SCM_STRING_CHARS (scm_wanted_attrib);
/* here is where you make it multi page aware */
nl_current = netlist_head;
/* search for the first instance */
/* through the entire list */
while (nl_current != NULL) {
if (nl_current->component_uref) {
if (strcmp(nl_current->component_uref, uref) == 0) {
/* first search outside the symbol */
return_value =
o_attrib_search_name_single(nl_current->object_ptr,
wanted_attrib, NULL);
if (return_value) {
break;
}
/* now search inside the symbol */
return_value =
o_attrib_search_name(nl_current->object_ptr->
complex->prim_objs, wanted_attrib,
0);
break;
}
}
nl_current = nl_current->next;
}
if (return_value) {
scm_return_value = scm_makfrom0str (return_value);
} else {
scm_return_value = scm_makfrom0str ("unknown");
}
return (scm_return_value);
}
/*! \brief
* \par Function Description
*
* \param [in] path
* \param [in] name Optional descriptive name for library directory.
* \return SCM_BOOL_T on success, SCM_BOOL_F otherwise.
*/
SCM g_rc_component_library(SCM path, SCM name)
{
gchar *string;
char *temp;
char *namestr = NULL;
SCM_ASSERT (scm_is_string (path), path,
SCM_ARG1, "component-library");
if (name != SCM_UNDEFINED) {
SCM_ASSERT (scm_is_string (name), name,
SCM_ARG2, "component-library");
namestr = scm_to_utf8_string (name);
}
/* take care of any shell variables */
temp = scm_to_utf8_string (path);
string = s_expand_env_variables (temp);
free (temp);
/* invalid path? */
if (!g_file_test (string, G_FILE_TEST_IS_DIR)) {
fprintf(stderr,
"Invalid path [%s] passed to component-library\n",
string);
if (namestr != NULL) {
free (namestr);
}
g_free(string);
return SCM_BOOL_F;
}
if (g_path_is_absolute (string)) {
s_clib_add_directory (string, namestr);
} else {
gchar *cwd = g_get_current_dir ();
gchar *temp;
temp = g_build_filename (cwd, string, NULL);
s_clib_add_directory (temp, namestr);
g_free(temp);
g_free(cwd);
}
if (namestr != NULL) {
free (namestr);
}
g_free(string);
return SCM_BOOL_T;
}
/*! \brief Use gschemdoc to open a browser to a specific wiki page
*
* \param [in] wikiname the name of the wiki page
*
* \par Function Description
* Invokes gschemdoc with its -w switch to open a browser to the wiki
* page specified by wikiname. If wikiname is empty or not a string,
* will browse to the main wiki page.
*/
SCM g_funcs_browse_wiki(SCM wikiname)
{
char *wikistr;
int pid;
/* Extract wiki name string from Scheme value structure.
* If not a string, use the empty string */
if (scm_is_string (wikiname)) {
wikistr = scm_to_utf8_string(wikiname);
} else {
wikistr = "";
}
#ifndef __MINGW32__
pid = fork();
if (pid < 0) {
/* Fork failed. Still in parent process, so can use the log
* window */
if (scm_is_string (wikiname))
free(wikistr);
s_log_message(_("Could not fork\n"));
return SCM_BOOL_F;
} else if (pid > 0) {
/* Parent process, we're finished here */
if (scm_is_string (wikiname))
free(wikistr);
return SCM_BOOL_T;
}
/* begin daughter process stuff */
/* assume gschemdoc is part of path */
char *gschemdoc = "gschemdoc";
char *wikiarg = "-w";
execlp(gschemdoc, gschemdoc, wikiarg, wikistr, NULL);
/* if we return, then nothing happened */
fprintf(stderr, _("Could not invoke %s\n"), gschemdoc);
_exit(0);
/* end daughter process stuff */
#else /* __MINGW32__ */
s_log_message(_("Documentation commands not supported under MinGW.\n"));
return SCM_BOOL_F;
#endif /* __MINGW32__ */
}
SCM g_get_pins(SCM uref)
{
SCM list = SCM_EOL;
NETLIST *nl_current;
CPINLIST *pl_current;
SCM_ASSERT(scm_is_string (uref), uref, SCM_ARG1, "gnetlist:get-pins");
/* here is where you make it multi page aware */
nl_current = netlist_head;
/* search for the first instance */
/* through the entire list */
while (nl_current != NULL) {
if (nl_current->component_uref) {
if (strcmp(nl_current->component_uref, SCM_STRING_CHARS (uref)) == 0) {
pl_current = nl_current->cpins;
while (pl_current != NULL) {
if (pl_current->pin_number) {
list = scm_cons (scm_makfrom0str (pl_current->pin_number),
list);
}
pl_current = pl_current->next;
}
}
}
nl_current = nl_current->next;
}
return (list);
}
/********************************************************************\
* 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;
}
/*! \todo Finish function documentation!!!
* \brief
* \par Function Description
*
*/
SCM g_rc_paper_sizes(SCM scm_papername, SCM scm_width, SCM scm_height)
#define FUNC_NAME "paper-sizes"
{
int width;
int height;
char *papername;
SCM ret;
SCM_ASSERT (scm_is_string (scm_papername), scm_papername,
SCM_ARG1, FUNC_NAME);
SCM_ASSERT (SCM_NIMP (scm_width) && SCM_REALP (scm_width), scm_width,
SCM_ARG2, FUNC_NAME);
SCM_ASSERT (SCM_NIMP (scm_height) && SCM_REALP (scm_height), scm_height,
SCM_ARG3, FUNC_NAME);
papername = SCM_STRING_CHARS (scm_papername);
width = (int) (SCM_NUM2DOUBLE (0, scm_width) * MILS_PER_INCH);
height = (int) (SCM_NUM2DOUBLE (0, scm_height) * MILS_PER_INCH);
if (!s_papersizes_uniq(papername)) {
ret = SCM_BOOL_F;
} else {
s_papersizes_add_entry(papername, width, height);
ret = SCM_BOOL_T;
}
return ret;
}
/*! \brief read the configuration string list for the component dialog
* \par Function Description
* This function reads the string list from the component-dialog-attributes
* configuration parameter and converts the list into a GList.
* The GList is stored in the global default_component_select_attrlist variable.
*/
SCM g_rc_component_dialog_attributes(SCM stringlist)
{
int length, i;
GList *list=NULL;
gchar *attr;
SCM_ASSERT(scm_list_p(stringlist), stringlist, SCM_ARG1, "scm_is_list failed");
length = scm_ilength(stringlist);
/* If the command is called multiple times, remove the old list before
recreating it */
g_list_foreach(default_component_select_attrlist, (GFunc)g_free, NULL);
g_list_free(default_component_select_attrlist);
/* convert the scm list into a GList */
for (i=0; i < length; i++) {
SCM_ASSERT(scm_is_string(scm_list_ref(stringlist, scm_from_int(i))),
scm_list_ref(stringlist, scm_from_int(i)), SCM_ARG1,
"list element is not a string");
attr = g_strdup(SCM_STRING_CHARS(scm_list_ref(stringlist, scm_from_int(i))));
list = g_list_prepend(list, attr);
}
default_component_select_attrlist = g_list_reverse(list);
return SCM_BOOL_T;
}
SCM
yacl_scm_b64url_decode (SCM scmb64)
{
if (!scm_is_string (scmb64))
scm_throw (scm_from_locale_symbol ("BADSTR"), SCM_BOOL_T);
size_t scmb64len, outlen;
char * b64url = scm_to_utf8_stringn (scmb64, &scmb64len);
if (NULL == b64url)
scm_throw (scm_from_locale_symbol ("BADDECODE"), SCM_BOOL_T);
uint8_t *decode = yacl_b64url_decode (b64url, &outlen);
free (b64url);
if (NULL == decode)
scm_throw (scm_from_locale_symbol ("BADDECODED"), SCM_BOOL_T);
SCM b64 = scm_c_make_bytevector (outlen);
memcpy (SCM_BYTEVECTOR_CONTENTS (b64), decode, outlen);
free (decode);
return b64;
}
/* this function will only return a unique list of packages */
SCM g_get_packages(SCM level)
{
SCM list = SCM_EOL;
GHashTable *ht;
NETLIST *nl_current = NULL;
SCM_ASSERT(scm_is_string (level), level, SCM_ARG1, "gnetlist:get-pins");
/* build a hash table */
ht = g_hash_table_new (g_str_hash, g_str_equal);
for (nl_current = netlist_head; nl_current != NULL;
nl_current = nl_current->next) {
if (nl_current->component_uref != NULL) {
/* add component_uref in the hash table */
/* uniqueness of component_uref is guaranteed by the hashtable */
if (g_hash_table_lookup (ht, nl_current->component_uref) == NULL) {
g_hash_table_insert (ht, nl_current->component_uref,
nl_current->component_uref);
list = scm_cons (scm_makfrom0str (nl_current->component_uref), list);
}
}
}
g_hash_table_destroy (ht);
return list;
}
/*! \todo Finish function documentation!!!
* \brief
* \par Function Description
*
*/
SCM g_funcs_image(SCM scm_filename)
{
char *filename;
SCM_ASSERT (scm_is_string (scm_filename), scm_filename,
SCM_ARG1, "gschem-image");
GSCHEM_TOPLEVEL *w_current = g_current_window ();
if (output_filename) {
x_image_lowlevel (w_current, output_filename,
w_current->image_width,
w_current->image_height,
g_strdup("png"));
} else {
filename = scm_to_utf8_string (scm_filename);
x_image_lowlevel (w_current, filename,
w_current->image_width,
w_current->image_height,
g_strdup("png"));
free(filename);
}
return SCM_BOOL_T;
}
SCM g_rc_gschlas_version(SCM scm_version)
{
char *version;
SCM ret = SCM_BOOL_T;
SCM_ASSERT (scm_is_string (scm_version), scm_version,
SCM_ARG1, "gschlas-version");
version = scm_to_utf8_string (scm_version);
if (g_strcasecmp (version, PACKAGE_DATE_VERSION) != 0) {
fprintf(stderr,
"You are running gEDA/gaf version [%s%s.%s],\n",
PREPEND_VERSION_STRING, PACKAGE_DOTTED_VERSION,
PACKAGE_DATE_VERSION);
fprintf(stderr,
"but you have a version [%s] gschlasrc file:\n[%s]\n",
version, rc_filename);
fprintf(stderr,
"Please be sure that you have the latest rc file.\n");
ret = SCM_BOOL_F;
}
free (version);
return ret;
}
static SCM
decode_scm_col_list (GttGhtml *ghtml, SCM col_list)
{
SCM col_name;
char * tok = NULL;
/* reset the parser */
ghtml->ninvl_cols = 0;
ghtml->ntask_cols = 0;
while (!scm_is_null (col_list))
{
col_name = SCM_CAR (col_list);
/* either a 'symbol or a "quoted string" */
if (!scm_is_symbol(col_name) && !scm_is_string (col_name))
{
col_list = SCM_CDR (col_list);
continue;
}
tok = scm_to_locale_string (col_name);
decode_column (ghtml, tok);
free (tok);
col_list = SCM_CDR (col_list);
}
return SCM_UNSPECIFIED;
}
/*! \brief Exports the keymap in scheme to a GLib GArray.
* \par Function Description
* This function converts the list of key sequence/action pairs
* returned by the scheme function \c dump-current-keymap into an
* array of C structures.
*
* The returned value must be freed by caller.
*
* \return A GArray with keymap data.
*/
GArray*
g_keys_dump_keymap (void)
{
SCM dump_proc = scm_c_lookup ("dump-current-keymap");
SCM scm_ret;
GArray *ret = NULL;
struct keyseq_action_t {
gchar *keyseq, *action;
};
dump_proc = scm_variable_ref (dump_proc);
g_return_val_if_fail (SCM_NFALSEP (scm_procedure_p (dump_proc)), NULL);
scm_ret = scm_call_0 (dump_proc);
g_return_val_if_fail (SCM_CONSP (scm_ret), NULL);
ret = g_array_sized_new (FALSE,
FALSE,
sizeof (struct keyseq_action_t),
(guint)scm_ilength (scm_ret));
for (; scm_ret != SCM_EOL; scm_ret = SCM_CDR (scm_ret)) {
SCM scm_keymap_entry = SCM_CAR (scm_ret);
struct keyseq_action_t keymap_entry;
g_return_val_if_fail (SCM_CONSP (scm_keymap_entry) &&
scm_is_symbol (SCM_CAR (scm_keymap_entry)) &&
scm_is_string (SCM_CDR (scm_keymap_entry)), ret);
keymap_entry.action = g_strdup (SCM_SYMBOL_CHARS (SCM_CAR (scm_keymap_entry)));
keymap_entry.keyseq = g_strdup (SCM_STRING_CHARS (SCM_CDR (scm_keymap_entry)));
ret = g_array_append_val (ret, keymap_entry);
}
return ret;
}
static Expr* eqv(Expr* args) {
assert(args);
if(scm_list_len(args) != 2) return scm_mk_error("eqv? expects 2 args");
Expr* fst = scm_car(args);
Expr* snd = scm_cadr(args);
if(fst == snd) return TRUE;
if(scm_is_pair(fst) || scm_is_pair(snd)) return FALSE;
if(scm_is_closure(fst) || scm_is_closure(snd)) return FALSE;
if(scm_is_num(fst) && scm_is_num(snd)) return num_eq(args);
if(scm_is_string(fst) && scm_is_string(snd) && strcmp(scm_sval(fst), scm_sval(snd)) == 0) return TRUE;
return FALSE;
}
/********************************************************************\
* gnc_get_credit_string *
* return a credit string for a given account type *
* *
* Args: account_type - type of account to get credit string for *
* Return: g_malloc'd credit string or NULL *
\********************************************************************/
char *
gnc_get_credit_string(GNCAccountType account_type)
{
const gchar *string;
SCM result;
SCM arg;
initialize_scm_functions();
if (gnc_gconf_get_bool(GCONF_GENERAL, KEY_ACCOUNTING_LABELS, NULL))
return g_strdup(_("Credit"));
if ((account_type < ACCT_TYPE_NONE) || (account_type >= NUM_ACCOUNT_TYPES))
account_type = ACCT_TYPE_NONE;
arg = scm_long2num(account_type);
result = scm_call_1(getters.credit_string, arg);
if (!scm_is_string(result))
return NULL;
string = scm_to_locale_string(result);
if (string)
return g_strdup(string);
return NULL;
}
/*! \todo Finish function documentation!!!
* \brief
* \par Function Description
*
*/
SCM g_rc_mode_general(SCM scmmode,
const char *rc_name,
int *mode_var,
const vstbl_entry *table,
int table_size)
{
SCM ret;
int index;
char *mode;
SCM_ASSERT (scm_is_string (scmmode), scmmode,
SCM_ARG1, rc_name);
mode = scm_to_utf8_string (scmmode);
index = vstbl_lookup_str(table, table_size, mode);
/* no match? */
if(index == table_size) {
fprintf(stderr,
"Invalid mode [%s] passed to %s\n",
mode,
rc_name);
ret = SCM_BOOL_F;
} else {
*mode_var = vstbl_get_val(table, index);
ret = SCM_BOOL_T;
}
free (mode);
return ret;
}
/*! \brief Add a directory to the Guile load path.
* \par Function Description
* Prepends \a s_path to the Guile system '%load-path', after
* expanding environment variables.
*
* \param [in] s_path Path to be added.
* \return SCM_BOOL_T.
*/
SCM g_rc_scheme_directory(SCM s_path)
{
char *temp;
gchar *expanded;
SCM s_load_path_var;
SCM s_load_path;
SCM_ASSERT (scm_is_string (s_path), s_path,
SCM_ARG1, "scheme-directory");
/* take care of any shell variables */
temp = scm_to_utf8_string (s_path);
expanded = s_expand_env_variables (temp);
s_path = scm_from_utf8_string (expanded);
free (temp);
g_free (expanded);
s_load_path_var = scm_c_lookup ("%load-path");
s_load_path = scm_variable_ref (s_load_path_var);
scm_variable_set_x (s_load_path_var, scm_cons (s_path, s_load_path));
scm_remember_upto_here_2 (s_load_path_var, s_load_path);
scm_remember_upto_here_1 (s_path);
return SCM_BOOL_T;
}
/*! \todo Finish function description!!!
* \brief
* \par Function Description
*
* \param [in] path
* \return SCM_BOOL_T on success, SCM_BOOL_F otherwise.
*/
SCM g_rc_bitmap_directory(SCM path)
{
gchar *string;
char *temp;
SCM_ASSERT (scm_is_string (path), path,
SCM_ARG1, "bitmap-directory");
/* take care of any shell variables */
temp = scm_to_utf8_string (path);
string = s_expand_env_variables (temp);
free (temp);
/* invalid path? */
if (!g_file_test (string, G_FILE_TEST_IS_DIR)) {
fprintf (stderr,
"Invalid path [%s] passed to bitmap-directory\n",
string);
g_free(string);
return SCM_BOOL_F;
}
g_free(default_bitmap_directory);
default_bitmap_directory = string;
return SCM_BOOL_T;
}
/*! \brief Get symbol data from a Scheme-based component source.
* \par Function Description
* Get symbol data from a Scheme-based component source. The return
* value should be free()'d when no longer needed.
*
* Private function used only in s_clib.c.
*
* \param symbol Symbol to get data for.
* \return Allocated buffer containing symbol data.
*/
static gchar *get_data_scm (const CLibSymbol *symbol)
{
SCM symdata;
char *tmp;
gchar *result;
g_return_val_if_fail ((symbol != NULL), NULL);
g_return_val_if_fail ((symbol->source->type == CLIB_SCM), NULL);
symdata = scm_call_1 (symbol->source->get_fn,
scm_from_utf8_string (symbol->name));
if (!scm_is_string (symdata)) {
s_log_message (_("Failed to load symbol data [%1$s] from source [%2$s]"),
symbol->name, symbol->source->name);
return NULL;
}
/* Need to make sure that the correct free() function is called
* on strings allocated by Guile. */
tmp = scm_to_utf8_string (symdata);
result = g_strdup(tmp);
free (tmp);
return result;
}
// String functions
static Expr* is_str(Expr* args) {
assert(args);
if(scm_list_len(args) != 1) return scm_mk_error("string? expects 1 arg");
return scm_is_string(scm_car(args)) ? TRUE: FALSE;
}
/* 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;
}
/*! \todo Finish function description!!!
* \brief
* \par Function Description
*
* \param [in] attrlist
* \return SCM_BOOL_T always.
*/
SCM g_rc_always_promote_attributes(SCM attrlist)
{
GList *list=NULL;
int length, i;
gchar *attr;
gchar **attr2;
g_list_foreach(default_always_promote_attributes, (GFunc)g_free, NULL);
g_list_free(default_always_promote_attributes);
if (scm_is_string (attrlist)) {
char *temp;
s_log_message(_("WARNING: using a string for 'always-promote-attributes'"
" is deprecated. Use a list of strings instead\n"));
/* convert the space separated strings into a GList */
temp = scm_to_utf8_string (attrlist);
attr2 = g_strsplit(temp," ", 0);
free (temp);
for (i=0; attr2[i] != NULL; i++) {
if (strlen(attr2[i]) > 0) {
list = g_list_prepend(list, g_strdup(attr2[i]));
}
}
g_strfreev(attr2);
} else {
SCM_ASSERT(scm_list_p(attrlist), attrlist, SCM_ARG1, "always-promote-attributes");
length = scm_ilength(attrlist);
/* convert the scm list into a GList */
for (i=0; i < length; i++) {
char *temp;
SCM_ASSERT(scm_is_string(scm_list_ref(attrlist, scm_from_int(i))),
scm_list_ref(attrlist, scm_from_int(i)), SCM_ARG1,
"always-promote-attribute: list element is not a string");
temp = scm_to_utf8_string (scm_list_ref (attrlist, scm_from_int (i)));
attr = g_strdup(temp);
free (temp);
list = g_list_prepend(list, attr);
}
}
default_always_promote_attributes = g_list_reverse(list);
return SCM_BOOL_T;
}
/*! \todo Finish function documentation!!!
* \brief
* \par Function Description
*
*/
SCM g_rc_scrollbar_update(SCM scmmode)
{
SCM ret = SCM_BOOL_T;
SCM_ASSERT (scm_is_string (scmmode), scmmode,
SCM_ARG1, "scrollbar-update");
return ret;
}
/* object being a pin */
char *s_net_return_connected_string(TOPLEVEL * pr_current, OBJECT * object,
char *hierarchy_tag)
{
OBJECT *o_current;
char *pinnum = NULL;
char *uref = NULL;
SCM scm_uref;
char *temp_uref = NULL;
char *string;
char *misc;
o_current = object;
pinnum = o_attrib_search_object_attribs_by_name (o_current, "pinnumber", 0);
#if DEBUG
printf("found pinnum: %s\n", pinnum);
#endif
scm_uref = g_scm_c_get_uref(pr_current, o_current->parent);
if (scm_is_string( scm_uref )) {
temp_uref = scm_to_utf8_string (scm_uref);
}
/* apply the hierarchy name to the uref */
uref = s_hierarchy_create_uref(pr_current, temp_uref, hierarchy_tag);
if (uref && pinnum) {
string = g_strdup_printf("%s %s", uref, pinnum);
} else {
if (pinnum) {
string = g_strdup_printf("POWER %s", pinnum);
} else {
if (hierarchy_tag) {
misc =
s_hierarchy_create_uref(pr_current, "U?",
hierarchy_tag);
string = g_strdup_printf("%s ?", misc);
g_free(misc);
} else {
string = g_strdup("U? ?");
}
fprintf(stderr, "Missing Attributes (refdes and pin number)\n");
}
}
g_free(pinnum);
g_free(uref);
g_free(temp_uref);
return (string);
}
KvpValue *
gnc_scm_to_kvp_value_ptr(SCM val)
{
if (scm_is_rational(val))
{
if (scm_is_exact(val) &&
(scm_is_signed_integer(val, INT64_MIN, INT64_MAX) ||
scm_is_unsigned_integer(val, INT64_MIN, INT64_MAX)))
{
return new KvpValue{scm_to_int64(val)};
}
else if (scm_is_exact(val) &&
(scm_is_signed_integer(scm_numerator(val),
INT64_MIN, INT64_MAX) ||
scm_is_unsigned_integer(scm_numerator(val),
INT64_MIN, INT64_MAX)) &&
(scm_is_signed_integer(scm_denominator(val),
INT64_MIN, INT64_MAX) ||
(scm_is_unsigned_integer(scm_denominator(val),
INT64_MIN, INT64_MAX))))
{
return new KvpValue{gnc_scm_to_numeric(val)};
}
else
{
return new KvpValue{scm_to_double(val)};
}
}
else if (gnc_guid_p(val))
{
auto guid = gnc_scm2guid(val);
auto tmpguid = guid_copy(&guid);
return new KvpValue{tmpguid};
}
else if (gnc_timepair_p(val))
{
Timespec ts = gnc_timepair2timespec(val);
return new KvpValue{ts};
}
else if (scm_is_string(val))
{
return new KvpValue{gnc_scm_to_utf8_string(val)};
}
else if (SWIG_IsPointerOfType(val, SWIG_TypeQuery("_p_KvpFrame")))
{
#define FUNC_NAME G_STRFUNC
auto vp_frame = SWIG_MustGetPtr(val,
SWIG_TypeQuery("_p_KvpFrame"), 1, 0);
KvpFrame *frame = static_cast<KvpFrame*>(vp_frame);
#undef FUNC_NAME
return new KvpValue{frame};
}
/* FIXME: add list handler here */
return NULL;
}
/*! \brief Guile callback for adding library commands.
* \par Function Description
* Callback function for the "component-library-command" Guile
* function, which can be used in the rc files to add a command to
* the component library.
*
* \param [in] listcmd command to get a list of symbols
* \param [in] getcmd command to get a symbol from the library
* \param [in] name Optional descriptive name for component source.
* \return SCM_BOOL_T on success, SCM_BOOL_F otherwise.
*/
SCM g_rc_component_library_command (SCM listcmd, SCM getcmd,
SCM name)
{
const CLibSource *src;
gchar *lcmdstr, *gcmdstr;
char *tmp_str, *namestr;
SCM_ASSERT (scm_is_string (listcmd), listcmd, SCM_ARG1,
"component-library-command");
SCM_ASSERT (scm_is_string (getcmd), getcmd, SCM_ARG2,
"component-library-command");
SCM_ASSERT (scm_is_string (name), name, SCM_ARG3,
"component-library-command");
scm_dynwind_begin(0);
/* take care of any shell variables */
/*! \bug this may be a security risk! */
tmp_str = scm_to_utf8_string (listcmd);
lcmdstr = s_expand_env_variables (tmp_str);
scm_dynwind_unwind_handler (g_free, lcmdstr, SCM_F_WIND_EXPLICITLY);
free (tmp_str); /* this should stay as free (allocated from guile) */
/* take care of any shell variables */
/*! \bug this may be a security risk! */
tmp_str = scm_to_utf8_string (getcmd);
gcmdstr = s_expand_env_variables (tmp_str);
scm_dynwind_unwind_handler (g_free, gcmdstr, SCM_F_WIND_EXPLICITLY);
free (tmp_str); /* this should stay as free (allocated from guile) */
namestr = scm_to_utf8_string (name);
src = s_clib_add_command (lcmdstr, gcmdstr, namestr);
free (namestr); /* this should stay as free (allocated from guile) */
scm_dynwind_end();
if (src != NULL) return SCM_BOOL_T;
return SCM_BOOL_F;
}
static Expr* str_null(Expr* args) {
assert(args);
if(scm_list_len(args) != 1) return scm_mk_error("string-null? expects 1 arg");
Expr* a = scm_car(args);
if(!scm_is_string(a)) return scm_mk_error("string-null? expects a string");
return scm_sval(a)[0] == '\0' ? TRUE : FALSE;
}
SCM g_rc_hierarchy_uref_separator(SCM name)
{
SCM_ASSERT (scm_is_string (name), name,
SCM_ARG1, "hierarchy-uref-separator");
g_free(default_hierarchy_uref_separator);
default_hierarchy_uref_separator = g_strdup_scm_string (name);
return SCM_BOOL_T;
}
/*! \todo Finish function documentation!!!
* \brief
* \par Function Description
*
*/
SCM g_rc_add_menu(SCM menu_name, SCM menu_items)
{
SCM_ASSERT (scm_is_string (menu_name), menu_name,
SCM_ARG1, "add-menu");
SCM_ASSERT (SCM_NIMP (menu_items) && SCM_CONSP (menu_items), menu_items,
SCM_ARG2, "add-menu");
s_menu_add_entry(SCM_STRING_CHARS (menu_name), menu_items);
return SCM_BOOL_T;
}
