#include <string.h>
#include <glib.h>
#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include <caml/memory.h>
#include <caml/fail.h>
#include <caml/callback.h>
#include <caml/custom.h>
#include <caml/signals.h>
#include "wrappers.h"
#include "ml_glib.h"
#include "glib_tags.h"
CAMLprim value
ml_g_io_channel_init_exn (value unit)
{
ml_register_exn_map (G_IO_CHANNEL_ERROR, "g_io_channel_error");
return Val_unit;
}
#define Val_none Val_unit
static value
ml_pair (value a, value b)
{
CAMLparam2(a, b);
value t;
t = alloc_small (2, 0);
Field (t, 0) = a;
Field (t, 1) = b;
CAMLreturn (t);
}
static value
caml_copy_string_len (const gchar *s, gsize len)
{
value v;
v = caml_alloc_string (len);
memcpy (String_val (v), s, len);
return v;
}
/* io_status : tags */
#include "giochannel_tags.h"
#include "giochannel_tags.c"
/* Make_Val_final_pointer (GIOChannel, Ignore, g_io_channel_unref, 20) */
extern value Val_GIOChannel (GIOChannel *);
#define GIOChannel_val(v) (GIOChannel *)Pointer_val(v)
CAMLprim value _ml_g_io_channel_unix_new (value fd)
{ return Val_GIOChannel (g_io_channel_unix_new (Int_val (fd))); }
/* ML_1(g_io_channel_unix_new, Int_val, Val_GIOChannel) */
ML_1(g_io_channel_unix_get_fd, GIOChannel_val, Val_int)
CAMLprim value
ml_g_io_channel_new_file (value v_fname, value v_mode)
{
GError *error = NULL;
GIOChannel *c;
gchar *fname, *mode;
fname = g_strdup (String_val (v_fname));
mode = g_strdup (String_val (v_mode));
enter_blocking_section ();
c = g_io_channel_new_file (fname, mode, &error);
leave_blocking_section ();
g_free (fname);
g_free (mode);
if (error) ml_raise_gerror (error);
return Val_GIOChannel (c);
}
static value
wrap_status_and_value (GIOStatus status, GError *err,
gboolean has_ret_val, value ret_val)
{
g_assert (err == NULL || status == G_IO_STATUS_ERROR);
switch (status)
{
case G_IO_STATUS_ERROR:
if (err == NULL)
err = g_error_new_literal (G_IO_CHANNEL_ERROR,
G_IO_CHANNEL_ERROR_FAILED,
"invalid arguments");
ml_raise_gerror (err);
break;
case G_IO_STATUS_NORMAL:
if (has_ret_val)
return ml_pair (MLTAG_NORMAL, ret_val);
else
return MLTAG_NORMAL;
case G_IO_STATUS_EOF:
return MLTAG_EOF;
case G_IO_STATUS_AGAIN:
return MLTAG_AGAIN;
}
g_assert_not_reached ();
return Val_unit;
}
static inline gboolean
check_substring (value s, gsize off, gsize len)
{
gsize str_len = string_length (s);
return off <= str_len && off + len <= str_len;
}
#ifdef G_OS_UNIX
# define IO_CHANNEL_BUF_SIZE PIPE_BUF
#else
# define IO_CHANNEL_BUF_SIZE 4096
#endif
CAMLprim value
ml_g_io_channel_read_chars (value c, value o_off, value o_len, value s)
{
CAMLparam1(s);
GError *err = NULL;
GIOStatus status;
GIOChannel *chan;
gchar buff[IO_CHANNEL_BUF_SIZE];
gsize bytes_read;
gsize off, len;
gboolean has_ret_val;
off = Option_val (o_off, Long_val, 0);
len = Option_val (o_len, Long_val, string_length (s) - off);
if (! check_substring (s, off, len))
invalid_argument ("invalid substring");
if (len > IO_CHANNEL_BUF_SIZE)
len = IO_CHANNEL_BUF_SIZE;
chan = GIOChannel_val (c);
enter_blocking_section ();
status = g_io_channel_read_chars (chan, buff, len, &bytes_read, &err);
leave_blocking_section ();
if (bytes_read > 0)
memcpy (String_val (s) + off, buff, bytes_read);
has_ret_val = status == G_IO_STATUS_NORMAL;
CAMLreturn (wrap_status_and_value (status, err, has_ret_val, Val_long (bytes_read)));
}
CAMLprim value
ml_g_io_channel_write_chars (value c, value written_ref,
value o_off, value o_len, value s)
{
CAMLparam2(c, written_ref);
GError *err = NULL;
GIOStatus status;
GIOChannel *chan;
gchar buff[IO_CHANNEL_BUF_SIZE];
gsize bytes_written;
gsize off, len;
off = Option_val (o_off, Long_val, 0);
len = Option_val (o_len, Long_val, string_length (s) - off);
if (! check_substring (s, off, len))
invalid_argument ("invalid substring");
if (len > IO_CHANNEL_BUF_SIZE)
len = IO_CHANNEL_BUF_SIZE;
chan = GIOChannel_val (c);
memcpy (buff, String_val (s) + off, len);
enter_blocking_section ();
status = g_io_channel_write_chars (chan, buff, len, &bytes_written, &err);
leave_blocking_section ();
if (Is_block (written_ref))
Field (Field (written_ref, 0), 0) = Val_long (bytes_written);
CAMLreturn (wrap_status_and_value (status, err, TRUE, Val_long (bytes_written)));
}
CAMLprim value
ml_g_io_channel_flush (value c)
{
GError *err = NULL;
GIOStatus status;
GIOChannel *chan;
chan = GIOChannel_val (c);
enter_blocking_section ();
status = g_io_channel_flush (chan, &err);
leave_blocking_section ();
return wrap_status_and_value (status, err, FALSE, Val_unit);
}
CAMLprim value
ml_g_io_channel_seek_position (value c, value off, value pos)
{
GError *err = NULL;
GIOStatus status;
GIOChannel *chan;
gint64 offset;
chan = GIOChannel_val (c);
offset = Int64_val (off);
enter_blocking_section ();
status = g_io_channel_seek_position (chan, offset, Seek_type_val (pos), &err);
leave_blocking_section ();
return wrap_status_and_value (status, err, FALSE, Val_unit);
}
CAMLprim value
ml_g_io_channel_shutdown (value c, value flush)
{
GError *err = NULL;
GIOStatus status;
GIOChannel *chan;
chan = GIOChannel_val (c);
enter_blocking_section ();
status = g_io_channel_shutdown (GIOChannel_val(c), Bool_val (flush), &err);
leave_blocking_section ();
if (status == G_IO_STATUS_ERROR || err != NULL)
return wrap_status_and_value (status, err, FALSE, Val_unit);
else
return Val_unit;
}
static gboolean
ml_GIOFunc (GIOChannel *source, GIOCondition condition, gpointer data)
{
value res, v_condition, *closure = data;
v_condition = ml_lookup_flags_getter (ml_table_io_condition, condition);
res = callback_exn (*closure, v_condition);
if (Is_exception_result (res))
{
g_warning ("GIOFunc callback raised an exception");
return FALSE;
}
return Bool_val (res);
}
static Make_Flags_val(Io_condition_val)
CAMLprim value
_ml_g_io_add_watch (value prio, value c, value conditions, value callback)
{
guint id;
id = g_io_add_watch_full (GIOChannel_val (c),
Option_val (prio, Int_val, G_PRIORITY_DEFAULT),
Flags_Io_condition_val (conditions),
ml_GIOFunc,
ml_global_root_new (callback),
ml_global_root_destroy);
return Val_int (id);
}
CAMLprim value
_ml_g_source_remove (value id)
{
if (! g_source_remove (Int_val(id)))
raise_not_found ();
return Val_unit;
}
ML_1 (g_io_channel_get_buffer_size, GIOChannel_val, Val_long)
ML_2 (g_io_channel_set_buffer_size, GIOChannel_val, Long_val, Unit)
#define copy_GIOCondition(f) ml_lookup_flags_getter (ml_table_io_condition, f)
ML_1 (g_io_channel_get_buffer_condition, GIOChannel_val, copy_GIOCondition)
#define copy_GIOFlags(f) ml_lookup_flags_getter (ml_table_io_flags, f)
ML_1 (g_io_channel_get_flags, GIOChannel_val, copy_GIOFlags)
static Make_Flags_val (Io_flags_val)
CAMLprim value
ml_g_io_channel_set_flags (value c, value flags)
{
GError *err = NULL;
GIOStatus status;
status = g_io_channel_set_flags (GIOChannel_val (c), Flags_Io_flags_val (flags), &err);
if (status == G_IO_STATUS_ERROR)
ml_raise_gerror (err);
g_assert (status == G_IO_STATUS_NORMAL);
return Val_unit;
}
CAMLprim value
ml_g_io_channel_get_line_term (value c)
{
G_CONST_RETURN gchar *line_term;
gint length;
line_term = g_io_channel_get_line_term (GIOChannel_val (c), &length);
if (line_term == NULL)
return Val_none;
else
return ml_some (caml_copy_string_len (line_term, length));
}
CAMLprim value
ml_g_io_channel_set_line_term (value c, value term)
{
gchar *line_term;
gint length;
if (Is_block (term))
{
value t = Field (term, 0);
line_term = String_val (t);
length = string_length (t);
}
else
{
line_term = NULL;
length = 0;
}
g_io_channel_set_line_term (GIOChannel_val (c), line_term, length);
return Val_unit;
}
ML_1 (g_io_channel_get_buffered, GIOChannel_val, Val_bool)
ML_2 (g_io_channel_set_buffered, GIOChannel_val, Bool_val, Unit)
CAMLprim value
ml_g_io_channel_get_encoding (value c)
{
G_CONST_RETURN gchar *encoding;
encoding = g_io_channel_get_encoding (GIOChannel_val (c));
if (encoding == NULL)
return Val_none;
else
return ml_some (copy_string (encoding));
}
CAMLprim value
ml_g_io_channel_set_encoding (value c, value enc)
{
GError *err = NULL;
GIOStatus status;
gchar *encoding;
encoding = String_option_val (enc);
status = g_io_channel_set_encoding (GIOChannel_val (c), encoding, &err);
if (status == G_IO_STATUS_ERROR)
{
if (err != NULL)
ml_raise_gerror (err);
else
invalid_argument ("GIOChannel.set_encoding");
}
g_assert (status == G_IO_STATUS_NORMAL);
return Val_unit;
}
ML_1 (g_io_channel_get_close_on_unref, GIOChannel_val, Val_bool)
ML_2 (g_io_channel_set_close_on_unref, GIOChannel_val, Bool_val, Unit)
syntax highlighted by Code2HTML, v. 0.9.1