void
graphicsGdImageMarkDestroyed(ScmObj obj)
{
SCM_ASSERT(SCM_FOREIGN_POINTER_P(obj));
Scm_ForeignPointerAttrSet(SCM_FOREIGN_POINTER(obj),
sym_destroyed, SCM_TRUE);
}
int
graphicsGdImageDestroyedP(ScmObj obj)
{
SCM_ASSERT(SCM_FOREIGN_POINTER_P(obj));
return !SCM_FALSEP(Scm_ForeignPointerAttrGet(SCM_FOREIGN_POINTER(obj),
sym_destroyed, SCM_FALSE));
}
/*------------------------------------------------------------
* Vport Getb
*/
static int vport_getb(ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->getb_proc)) {
/* If the port doesn't have get-byte method, use get-char
if possible. */
char buf[SCM_CHAR_MAX_BYTES];
if (SCM_FALSEP(data->getc_proc)) return EOF;
ScmObj ch = Scm_ApplyRec(data->getc_proc, SCM_NIL);
if (!SCM_CHARP(ch)) return EOF;
ScmChar c = SCM_CHAR_VALUE(ch);
int nb = SCM_CHAR_NBYTES(c);
SCM_CHAR_PUT(buf, c);
for (int i=1; i<nb; i++) {
/* pushback for later use. this isn't very efficient;
if efficiency becomes a problem, we need another API
to pushback multiple bytes. */
Scm_UngetbUnsafe(buf[i], p);
}
return (unsigned char)buf[0];
} else {
ScmObj b = Scm_ApplyRec(data->getb_proc, SCM_NIL);
if (!SCM_INTP(b)) return EOF;
return (SCM_INT_VALUE(b) & 0xff);
}
}
/*------------------------------------------------------------
* Vport puts
*/
static void vport_puts(ScmString *s, ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
const ScmStringBody *b = SCM_STRING_BODY(s);
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->puts_proc)) {
Scm_ApplyRec(data->puts_proc, SCM_LIST1(SCM_OBJ(s)));
} else if (SCM_STRING_BODY_INCOMPLETE_P(b)
|| (SCM_FALSEP(data->putc_proc)
&& !SCM_FALSEP(data->putb_proc))) {
/* we perform binary output */
vport_putz(SCM_STRING_BODY_START(b), SCM_STRING_BODY_SIZE(b), p);
} else if (!SCM_FALSEP(data->putc_proc)) {
const char *cp = SCM_STRING_BODY_START(b);
for (int i=0; i < (int)SCM_STRING_BODY_LENGTH(b); i++) {
ScmChar c;
SCM_CHAR_GET(cp, c);
cp += SCM_CHAR_NFOLLOWS(*cp)+1;
Scm_ApplyRec(data->putc_proc, SCM_LIST1(SCM_MAKE_CHAR(c)));
}
} else {
Scm_PortError(p, SCM_PORT_ERROR_OTHER,
"cannot perform output to the port %S", p);
}
}
/**
* Replace entire content of recentmost frame of an env
*
* The environment must be replaced with returned one in caller side even if
* this implementation returns identical to the one passed. This rule is
* required to be compatible with future alternative implementations.
*/
SCM_EXPORT ScmObj
scm_replace_environment(ScmObj formals, ScmObj actuals, ScmObj env)
{
ScmObj frame;
DECLARE_INTERNAL_FUNCTION("scm_replace_environment");
SCM_ASSERT(scm_valid_environment_extensionp(formals, actuals));
SCM_ASSERT(VALID_ENVP(env));
SCM_ASSERT(CONSP(env));
frame = CAR(env);
SET_CAR(frame, formals);
SET_CDR(frame, actuals);
return env;
}
/* places a single char in the input buffer. */
static int
sf_fill_input (SCM port)
{
SCM p = SCM_PACK (SCM_STREAM (port));
SCM ans;
scm_t_port *pt;
ans = scm_call_0 (SCM_SIMPLE_VECTOR_REF (p, 3)); /* get char. */
if (scm_is_false (ans) || SCM_EOF_OBJECT_P (ans))
return EOF;
SCM_ASSERT (SCM_CHARP (ans), ans, SCM_ARG1, "sf_fill_input");
pt = SCM_PTAB_ENTRY (port);
if (pt->encoding == NULL)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
*pt->read_buf = SCM_CHAR (ans);
pt->read_pos = pt->read_buf;
pt->read_end = pt->read_buf + 1;
return *pt->read_buf;
}
else
scm_ungetc_unlocked (SCM_CHAR (ans), port);
return SCM_CHAR (ans);
}
/*------------------------------------------------------------
* Vport Getc
*/
static int vport_getc(ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->getc_proc)) {
/* If the port doesn't have get-char method, try get-byte */
char buf[SCM_CHAR_MAX_BYTES];
if (SCM_FALSEP(data->getb_proc)) return EOF;
ScmObj b = Scm_ApplyRec(data->getb_proc, SCM_NIL);
if (!SCM_INTP(b)) return EOF;
buf[0] = (char)SCM_INT_VALUE(b);
int n = SCM_CHAR_NFOLLOWS(p->scratch[0]);
for (int i=0; i<n; i++) {
b = Scm_ApplyRec(data->getb_proc, SCM_NIL);
if (!SCM_INTP(b)) {
/* TODO: should raise an exception? */
return EOF;
}
buf[i+1] = (char)SCM_INT_VALUE(b);
}
ScmChar ch;
SCM_CHAR_GET(buf, ch);
return ch;
} else {
ScmObj ch = Scm_ApplyRec(data->getc_proc, SCM_NIL);
if (!SCM_CHARP(ch)) return EOF;
return SCM_CHAR_VALUE(ch);
}
}
/*
* External entry to manage registering callbacks
* 'xtra1' and 'xtra2' are ignored by most callbacks; only the two callbacks
* use them:
* glutTimerFunc: xtra1 for millliseconds, xtra2 for value
* glutJoystickFunc: xtra1 for interval
*/
void Scm_GlutRegisterCallback(int type, ScmObj closure, int xtra1, int xtra2)
{
SCM_ASSERT(type >= 0 && type < SCM_GLUT_NUM_CBS);
if (type < SCM_GLUT_NUM_WINDOW_CBS) {
int win = glutGetWindow();
ScmObj entry = Scm_HashTableRef(SCM_HASH_TABLE(ScmGlutCallbackTable),
SCM_MAKE_INT(win), SCM_FALSE);
if (SCM_EQ(entry, SCM_FALSE)) {
entry = Scm_MakeVector(SCM_GLUT_NUM_WINDOW_CBS, SCM_FALSE);
Scm_HashTableSet(SCM_HASH_TABLE(ScmGlutCallbackTable),
SCM_MAKE_INT(win), entry, 0);
}
SCM_VECTOR_ELEMENT(entry, type) = closure;
registrars[type](!SCM_FALSEP(closure), xtra1);
} else if (type == SCM_GLUT_CB_IDLE) {
idle_closure = closure;
if (SCM_FALSEP(closure)) {
glutIdleFunc(NULL);
} else {
glutIdleFunc(idle_cb);
}
} else {
timer_closure = closure;
if (!SCM_FALSEP(closure)) {
glutTimerFunc(xtra1, timer_cb, xtra2);
}
}
}
/*! \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;
}
/* 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_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;
}
SCM DLL_PUBLIC
cl_dump_handle (SCM handle)
{
handle_post_t *hp;
SCM_ASSERT (_scm_is_handle (handle), handle, SCM_ARG1, "%curl-dump-handle");
hp = _scm_to_handle (handle);
fprintf (stderr, "<#handle %p>\n", hp);
fprintf (stderr, "\t handle %p\n", hp->handle);
fprintf (stderr, "\t postfields %p\n", hp->postfields);
fprintf (stderr, "\t postfieldsize %zu\n", hp->postfieldsize);
print_mem (hp->postfields, hp->postfieldsize);
fprintf (stderr, "\t httppost %p\n", hp->httppost);
print_httppost (hp->httppost);
fprintf (stderr, "\t httpheader %p\n", hp->httpheader);
print_slist (hp->httpheader);
fprintf (stderr, "\thttp200aliases %p\n", hp->http200aliases);
print_slist (hp->http200aliases);
fprintf (stderr, "\t mail_rcpt %p\n", hp->mail_rcpt);
print_slist (hp->mail_rcpt);
fprintf (stderr, "\t quote %p\n", hp->quote);
print_slist (hp->quote);
fprintf (stderr, "\t postquote %p\n", hp->postquote);
print_slist (hp->postquote);
fprintf (stderr, "\t prequote %p\n", hp->prequote);
print_slist (hp->prequote);
fprintf (stderr, "\t resolve %p\n", hp->resolve);
print_slist (hp->resolve);
fprintf (stderr, "\t telnetoptions %p\n", hp->telnetoptions);
print_slist (hp->telnetoptions);
fflush (stderr);
return SCM_UNDEFINED;
}
/*
*Returns a list of the pins of the <B>object smob</B>.
*/
SCM g_get_object_pins (SCM object_smob)
{
TOPLEVEL *toplevel=NULL;
OBJECT *object=NULL;
OBJECT *prim_obj;
GList *iter;
SCM returned=SCM_EOL;
/* Get toplevel and o_current */
SCM_ASSERT (g_get_data_from_object_smob (object_smob, &toplevel, &object),
object_smob, SCM_ARG1, "get-object-pins");
if (!object) {
return (returned);
}
if (object->complex && object->complex->prim_objs) {
iter = object->complex->prim_objs;
while (iter != NULL) {
prim_obj = (OBJECT *)iter->data;
if (prim_obj->type == OBJ_PIN) {
returned = scm_cons (g_make_object_smob(toplevel, prim_obj),returned);
}
iter = g_list_next (iter);
}
}
return (returned);
}
void Scm_PutbUnsafe(ScmByte b, ScmPort *p)
#endif
{
VMDECL;
SHORTCUT(p, Scm_PutbUnsafe(b, p); return);
WALKER_CHECK(p);
LOCK(p);
CLOSE_CHECK(p);
switch (SCM_PORT_TYPE(p)) {
case SCM_PORT_FILE:
if (p->src.buf.current >= p->src.buf.end) {
SAFE_CALL(p, bufport_flush(p, (int)(p->src.buf.current - p->src.buf.buffer), FALSE));
}
SCM_ASSERT(p->src.buf.current < p->src.buf.end);
*p->src.buf.current++ = b;
if (SCM_PORT_BUFFER_MODE(p) == SCM_PORT_BUFFER_NONE) {
SAFE_CALL(p, bufport_flush(p, 1, FALSE));
}
UNLOCK(p);
break;
case SCM_PORT_OSTR:
SCM_DSTRING_PUTB(&p->src.ostr, b);
UNLOCK(p);
break;
case SCM_PORT_PROC:
SAFE_CALL(p, p->src.vt.Putb(b, p));
UNLOCK(p);
break;
default:
UNLOCK(p);
Scm_PortError(p, SCM_PORT_ERROR_OUTPUT,
"bad port type for output: %S", p);
}
}
/*------------------------------------------------------------
* Vport Gets
*/
static int vport_getz(char *buf, int buflen, ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->gets_proc)) {
u_int size;
ScmObj s = Scm_ApplyRec(data->gets_proc,
SCM_LIST1(SCM_MAKE_INT(buflen)));
if (!SCM_STRINGP(s)) return EOF;
const char *start = Scm_GetStringContent(SCM_STRING(s), &size,
NULL, NULL);
if ((int)size > buflen) {
/* NB: should raise an exception? */
memcpy(buf, start, buflen);
return buflen;
} else {
memcpy(buf, start, size);
return size;
}
} else {
int i = 0;
for (; i<buflen; i++) {
int byte = vport_getb(p);
if (byte == EOF) break;
buf[i] = byte;
}
if (i==0) return EOF;
else return i;
}
}
SCM_EXPORT void
scm_pop_trace_frame(void)
{
SCM_ASSERT(CONSP(l_trace_stack));
l_trace_stack = CDR(l_trace_stack);
}
/* Converts a bignum b to a double. b must be normalized.
We don't rely on double arithmetic, for it may result
an error in the LSB from multiple roundings. Instead we
extract bits directly from the bignum values array.
(We use ScmBits API by casting b->values to ScmBits*).
*/
double Scm_BignumToDouble(const ScmBignum *b)
{
ScmBits *bits = (ScmBits*)b->values;
ScmBits dst[2];
int maxbit, exponent;
/* first, filter out a special case. */
if (b->size == 0) return 0.0;
maxbit = Scm_BitsHighest1(bits, 0, b->size*WORD_BITS);
exponent = maxbit+1023;
#if SIZEOF_LONG >= 8
SCM_ASSERT(maxbit >= 54); /* because b is normalized */
dst[0] = 0;
Scm_BitsCopyX(dst, 0, bits, maxbit-52, maxbit);
/* Rounding. We have to round up if maxbit-53 == 1, EXCEPT
the special case where maxbit-52==0, maxbit-53==1, and all
bits below are 0 (round-to-even rule) */
if (SCM_BITS_TEST(bits, maxbit-53)
&& ((dst[0]&1) == 1
|| (Scm_BitsCount1(bits, 0, maxbit-53) > 0))) {
dst[0]++;
if (dst[0] >= (1UL<<52)) {
/* Overflow. We mask the hidden bit, then shift. */
dst[0] &= ~(1UL<<52);
dst[0] >>= 1;
exponent++;
}
int Scm_PeekbUnsafe(ScmPort *p)
#endif
{
int b;
VMDECL;
SHORTCUT(p, return Scm_PeekbUnsafe(p));
LOCK(p);
if (p->scrcnt > 0) {
b = (unsigned char)p->scratch[0];
} else {
SCM_GETB(b, p);
if (b >= 0) {
if (p->scrcnt > 0) {
/* unshift scratch buffer */
SCM_ASSERT(p->scrcnt < SCM_CHAR_MAX_BYTES);
for (int i=p->scrcnt; i>0; i--) {
p->scratch[i] = p->scratch[i-1];
}
p->scratch[0] = b;
p->scrcnt++;
} else {
p->scratch[0] = b;
p->scrcnt = 1;
}
}
}
UNLOCK(p);
return b;
}
GList *
gnc_scm_list_to_glist(SCM rest)
{
GList *result = NULL;
SCM scm_item;
SWIG_GetModule(NULL); /* Work-around for SWIG bug. */
SCM_ASSERT(scm_is_list(rest), rest, SCM_ARG1, "gnc_scm_list_to_glist");
while (!scm_is_null(rest))
{
void *item;
scm_item = SCM_CAR(rest);
rest = SCM_CDR(rest);
if (scm_item == SCM_BOOL_F)
{
result = g_list_prepend(result, NULL);
}
else
{
if (!SWIG_IsPointer(scm_item))
scm_misc_error("gnc_scm_list_to_glist",
"Item in list not a wcp.", scm_item);
item = (void *)SWIG_PointerAddress(scm_item);
result = g_list_prepend(result, item);
}
}
return g_list_reverse(result);
}
static SCM
guile_sock_no_delay (SCM sock, SCM enable)
{
svz_socket_t *xsock;
int old = 0, set = 0;
scm_assert_smob_type (guile_svz_socket_tag, sock);
xsock = (svz_socket_t *) SCM_SMOB_DATA (sock);
if (xsock->proto & PROTO_TCP)
{
if (!SCM_UNBNDP (enable))
{
SCM_ASSERT (scm_is_bool (enable) || scm_is_integer (enable), enable,
SCM_ARG2, FUNC_NAME);
if ((scm_is_bool (enable) && scm_is_true (enable)) ||
(scm_is_integer (enable) && scm_to_int (enable) != 0))
set = 1;
}
if (svz_tcp_nodelay (xsock->sock_desc, set, &old) < 0)
old = 0;
else if (SCM_UNBNDP (enable))
svz_tcp_nodelay (xsock->sock_desc, old, NULL);
}
return SCM_BOOL (old);
}
/*! \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_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);
}
/**
* Lookup a variable of an env
*
* @return Reference to the variable. SCM_INVALID_REF if not found.
*/
SCM_EXPORT ScmRef
scm_lookup_environment(ScmObj var, ScmObj env)
{
ScmObj frame;
ScmRef ref;
#if SCM_USE_HYGIENIC_MACRO
scm_int_t depth, id_depth;
ScmObj env_save;
#endif /* SCM_USE_HYGIENIC_MACRO */
DECLARE_INTERNAL_FUNCTION("scm_lookup_environment");
SCM_ASSERT(IDENTIFIERP(var));
SCM_ASSERT(VALID_ENVP(env));
/* lookup in frames */
#if SCM_USE_HYGIENIC_MACRO
env_save = env;
depth = 0;
#endif
for (; !NULLP(env); env = CDR(env)) {
frame = CAR(env);
ref = scm_lookup_frame(var, frame);
if (ref != SCM_INVALID_REF)
return ref;
#if SCM_USE_HYGIENIC_MACRO
++depth;
#endif
}
SCM_ASSERT(NULLP(env));
#if SCM_USE_HYGIENIC_MACRO
if (FARSYMBOLP(var)) {
scm_int_t i;
id_depth = SCM_FARSYMBOL_ENV(var);
if (id_depth > depth)
scm_macro_bad_scope(var);
for (i = depth - id_depth; i--; )
env_save = CDR(env_save);
ref = lookup_n_frames(SCM_FARSYMBOL_SYM(var),
id_depth, env_save);
SCM_ASSERT(ref != SCM_INVALID_REF || SYMBOLP(SCM_FARSYMBOL_SYM(var)));
return ref;
}
#endif
return SCM_INVALID_REF;
}
/*------------------------------------------------------------
* Bport close
*/
static void bport_close(ScmPort *p)
{
bport *data = (bport*)p->src.buf.data;
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->close_proc)) {
Scm_ApplyRec(data->close_proc, SCM_NIL);
}
}
static ScmObj
scm_p_set_macro_debug_flagsx(ScmObj new_mode)
{
SCM_ASSERT(INTP(new_mode));
l_debug_mode = SCM_INT_VALUE(new_mode);
return SCM_UNDEF;
}
/*------------------------------------------------------------
* Vport flush
*/
static void vport_flush(ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->flush_proc)) {
Scm_ApplyRec(data->flush_proc, SCM_NIL);
}
}
/*! \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");
scm_dynwind_begin (0);
if (name != SCM_UNDEFINED) {
SCM_ASSERT (scm_is_string (name), name,
SCM_ARG2, "component-library");
namestr = scm_to_utf8_string (name);
scm_dynwind_free(namestr);
}
/* take care of any shell variables */
temp = scm_to_utf8_string (path);
string = s_expand_env_variables (temp);
scm_dynwind_unwind_handler (g_free, string, SCM_F_WIND_EXPLICITLY);
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);
scm_dynwind_end();
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);
}
scm_dynwind_end();
return SCM_BOOL_T;
}
/*! \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;
}
SCM DLL_PUBLIC
cl_easy_perform (SCM handle, SCM bvflag, SCM headerflag)
{
handle_post_t *c_handle;
SCM data;
CURLcode status;
struct scm_flag body_sf, header_sf;
SCM_ASSERT (_scm_is_handle (handle), handle, SCM_ARG1, "%curl-easy-perform");
c_handle = _scm_to_handle (handle);
body_sf.flag = scm_is_true (bvflag);
#if SCM_MAJOR_VERSION == 2
if (body_sf.flag)
data = scm_c_make_bytevector (0);
else
data = scm_c_make_string (0, SCM_MAKE_CHAR('\n'));
#else
data = scm_c_make_string (0, SCM_MAKE_CHAR('\n'));
#endif
body_sf.scm = data;
header_sf.flag = 0;
#if SCM_MAJOR_VERSION == 2
if (header_sf.flag)
data = scm_c_make_bytevector (0);
else
data = scm_c_make_string (0, SCM_MAKE_CHAR('\n'));
#else
data = scm_c_make_string (0, SCM_MAKE_CHAR('\n'));
#endif
header_sf.scm = data;
if (scm_is_true (headerflag))
{
curl_easy_setopt (c_handle->handle, CURLOPT_HEADERFUNCTION, write_callback);
curl_easy_setopt (c_handle->handle, CURLOPT_HEADERDATA, &header_sf);
curl_easy_setopt (c_handle->handle, CURLOPT_ERRORBUFFER, error_string);
}
curl_easy_setopt (c_handle->handle, CURLOPT_WRITEFUNCTION, write_callback);
curl_easy_setopt (c_handle->handle, CURLOPT_WRITEDATA, &body_sf);
curl_easy_setopt (c_handle->handle, CURLOPT_ERRORBUFFER, error_string);
/* Do the transfer, and fill c_str with the result */
status = curl_easy_perform (c_handle->handle);
if (status != CURLE_OK)
{
error_code = status;
return (SCM_BOOL_F);
}
if (scm_is_true (headerflag))
return (scm_list_2 (header_sf.scm, body_sf.scm));
return (body_sf.scm);
}
