[perl-Glib-Object-Introspection] Add support for GHashTable

[Emmanuele Bassi <ebassi src gnome org>]

commit 062af95483033814eb02719c42f771c871bc6e1e
Author: Emmanuele Bassi <ebassi linux intel com>
Date:   Sat Mar 5 12:10:54 2011 +0000

    Add support for GHashTable
    
    Allow GHashTable â?? SV translation for in and out arguments as well as
    return values.
    
    Use the Regress test suite to verify that everything works.

 GObjectIntrospection.xs |  181 ++++++++++++++++++++++++++++++++++++++++++++++-
 t/hashes.t              |   21 ++++++
 2 files changed, 200 insertions(+), 2 deletions(-)
---
diff --git a/GObjectIntrospection.xs b/GObjectIntrospection.xs
index 895dd4d..2e79cbc 100644
--- a/GObjectIntrospection.xs
+++ b/GObjectIntrospection.xs
@@ -829,6 +829,183 @@ sv_to_glist (GIArgInfo * arg_info, GITypeInfo * type_info, SV * sv)
 	return list;
 }
 
+static SV *
+ghash_to_sv (GITypeInfo *info,
+             gpointer pointer,
+             GITransfer transfer)
+{
+	GITypeInfo *key_param_info, *value_param_info;
+#ifdef NOISY
+        GITypeTag key_type_tag, value_type_tag;
+#endif
+        gpointer key_p, value_p;
+	GITransfer item_transfer;
+	GHashTableIter iter;
+	HV *hv;
+
+	if (pointer == NULL) {
+		return &PL_sv_undef;
+	}
+
+	item_transfer = transfer == GI_TRANSFER_EVERYTHING
+		      ? GI_TRANSFER_EVERYTHING
+                      : GI_TRANSFER_NOTHING;
+
+	key_param_info = g_type_info_get_param_type (info, 0);
+        value_param_info = g_type_info_get_param_type (info, 1);
+
+#ifdef NOISY
+        key_type_tag = g_type_info_get_tag (key_param_info);
+        value_type_tag = g_type_info_get_tag (value_param_info);
+#endif
+
+	dwarn ("    GHashTable: pointer %p\n"
+               "      key type tag %d (%s)\n"
+               "      value type tag %d (%s)\n",
+	       pointer,
+	       key_type_tag, g_type_tag_to_string (key_type_tag),
+	       value_type_tag, g_type_tag_to_string (value_type_tag));
+
+	hv = newHV ();
+
+        g_hash_table_iter_init (&iter, pointer);
+        while (g_hash_table_iter_next (&iter, &key_p, &value_p)) {
+		GIArgument arg = { 0, };
+                SV *key_sv, *value_sv;
+
+		dwarn ("      converting key pointer %p\n", key_p);
+		arg.v_pointer = key_p;
+		key_sv = arg_to_sv (&arg, key_param_info, item_transfer);
+		if (key_sv == NULL)
+                        break;
+
+                dwarn ("      converting value pointer %p\n", value_p);
+                arg.v_pointer = value_p;
+                value_sv = arg_to_sv (&arg, value_param_info, item_transfer);
+                if (value_sv == NULL)
+                        break;
+
+                (void) hv_store_ent (hv, key_sv, value_sv, 0);
+	}
+
+	g_base_info_unref ((GIBaseInfo *) key_param_info);
+        g_base_info_unref ((GIBaseInfo *) value_param_info);
+
+	return newRV_noinc ((SV *) hv);
+}
+
+static gpointer
+sv_to_ghash (GIArgInfo *arg_info,
+             GITypeInfo *type_info,
+             SV *sv)
+{
+	HV *hv;
+        HE *he;
+	GITransfer transfer, item_transfer;
+	gpointer hash;
+	GITypeInfo *key_param_info, *value_param_info;
+        GITypeTag key_type_tag;
+        GHashFunc hash_func;
+        GEqualFunc equal_func;
+        I32 n_keys;
+
+	dwarn ("%s: sv %p\n", G_STRFUNC, sv);
+
+	if (sv == &PL_sv_undef)
+		return NULL;
+
+	if (!gperl_sv_is_hash_ref (sv))
+		ccroak ("need an hash ref to convert to GHashTable");
+
+	hv = (HV *) SvRV (sv);
+
+	item_transfer = GI_TRANSFER_NOTHING;
+	transfer = g_arg_info_get_ownership_transfer (arg_info);
+	switch (transfer) {
+	    case GI_TRANSFER_EVERYTHING:
+		item_transfer = GI_TRANSFER_EVERYTHING;
+		break;
+	    case GI_TRANSFER_CONTAINER:
+		/* nothing special to do */
+		break;
+	    case GI_TRANSFER_NOTHING:
+		/* FIXME: need to free list after call */
+		break;
+	}
+
+	key_param_info = g_type_info_get_param_type (type_info, 0);
+        value_param_info = g_type_info_get_param_type (type_info, 1);
+
+        key_type_tag = g_type_info_get_tag (key_param_info);
+
+        switch (key_type_tag)
+          {
+          case GI_TYPE_TAG_FILENAME:
+          case GI_TYPE_TAG_UTF8:
+            hash_func = g_str_hash;
+            equal_func = g_str_equal;
+            break;
+
+          default:
+            hash_func = NULL;
+            equal_func = NULL;
+            break;
+          }
+
+	dwarn ("  GHashTable with transfer %d\n"
+               "    key_param_info %p with type tag %d (%s)\n"
+               "    value_param_info %p with type tag %d (%s)\n",
+               transfer,
+	       key_param_info,
+	       g_type_info_get_tag (key_param_info),
+	       g_type_tag_to_string (g_type_info_get_tag (key_param_info)),
+	       value_param_info,
+	       g_type_info_get_tag (value_param_info),
+	       g_type_tag_to_string (g_type_info_get_tag (value_param_info)));
+
+        hash = g_hash_table_new (hash_func, equal_func);
+
+        n_keys = hv_iterinit (hv);
+        if (n_keys == 0)
+                goto out;
+
+        while ((he = hv_iternext (hv)) != NULL) {
+                SV *sv;
+                GIArgument arg = { 0, };
+                gpointer key_p, value_p;
+
+                key_p = value_p = NULL;
+
+                sv = hv_iterkeysv (he);
+		if (sv && gperl_sv_is_defined (sv)) {
+			dwarn ("    converting key SV %p\n", sv);
+			/* FIXME: Is it OK to always allow undef here? */
+			sv_to_arg (sv, &arg, NULL, key_param_info,
+			           item_transfer, TRUE, NULL);
+                        key_p = arg.v_pointer;
+		}
+
+                sv = hv_iterval (hv, he);
+                if (sv && gperl_sv_is_defined (sv)) {
+                        dwarn ("    converting value SV %p\n", sv);
+                        sv_to_arg (sv, &arg, NULL, key_param_info,
+                                   item_transfer, TRUE, NULL);
+                        value_p = arg.v_pointer;
+                }
+
+                if (key_p != NULL && value_p != NULL)
+                        g_hash_table_insert (hash, key_p, value_p);
+	}
+
+out:
+	dwarn ("    -> hash %p of size %d\n", list, g_hash_table_size (hash));
+
+        g_base_info_unref ((GIBaseInfo *) key_param_info);
+	g_base_info_unref ((GIBaseInfo *) value_param_info);
+
+	return hash;
+}
+
 /* ------------------------------------------------------------------------- */
 
 static void
@@ -1120,7 +1297,7 @@ sv_to_arg (SV * sv,
 		break;
 
 	    case GI_TYPE_TAG_GHASH:
-		ccroak ("FIXME - GI_TYPE_TAG_GHASH");
+                arg->v_pointer = sv_to_ghash (arg_info, type_info, sv);
 		break;
 
 	    case GI_TYPE_TAG_ERROR:
@@ -1213,7 +1390,7 @@ arg_to_sv (GIArgument * arg,
 		return glist_to_sv (info, arg->v_pointer, transfer);
 
 	    case GI_TYPE_TAG_GHASH:
-		ccroak ("FIXME - GI_TYPE_TAG_GHASH");
+                return ghash_to_sv (info, arg->v_pointer, transfer);
 
 	    case GI_TYPE_TAG_ERROR:
 		ccroak ("FIXME - GI_TYPE_TAG_ERROR");
diff --git a/t/hashes.t b/t/hashes.t
new file mode 100644
index 0000000..5d60d62
--- /dev/null
+++ b/t/hashes.t
@@ -0,0 +1,21 @@
+#!/usr/bin/env perl
+
+BEGIN { require './t/inc/setup.pl' };
+
+use strict;
+use warnings;
+use utf8;
+
+plan tests => 8;
+
+is(test_ghash_null_return(), undef);
+is_deeply(test_ghash_nothing_return(), { foo => 'bar', baz => 'bat', qux => 'quux' });
+is_deeply(test_ghash_nothing_return2(), { foo => 'bar', baz => 'bat', qux => 'quux' });
+is_deeply(test_ghash_container_return(), { foo => 'bar', baz => 'bat', qux => 'quux' });
+is_deeply(test_ghash_everything_return(), { foo => 'bar', baz => 'bat', qux => 'quux' });
+test_ghash_null_in(undef);
+is(test_ghash_null_out(), undef);
+test_ghash_nothing_in({ foo => 'bar', baz => 'bat', qux => 'quux' });
+test_ghash_nothing_in2({ foo => 'bar', baz => 'bat', qux => 'quux' });
+is_deeply(test_ghash_nested_everything_return(), { wibble => { foo => 'bar', baz => 'bat', qux => 'quux', }, });
+is_deeply(test_ghash_nested_everything_return2(), { wibble => { foo => 'bar', baz => 'bat', qux => 'quux', }, });