Below is the file 'glib/ocaml-giochannel.c' from this revision. You can also download the file.

#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_fd (value fd)
{
  GIOChannel *c;
#ifdef G_OS_WIN32
  c = g_io_channel_win32_new_fd (Int_val (fd));
#else
  c = g_io_channel_unix_new (Int_val (fd));
#endif
  return Val_GIOChannel (c);
}

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)