Binding perl: many improvements

 * handle GHashTable of strings and objects.
 * report errors with 'croak' as a Lasso::Error object.
 * add more basic tests.
 * for string arguments, convert undef to NULL, and croak if function
   does not accept NULL.
 * fix library paths in Makefile.PL.

9 files changed, 292 insertions, 33 deletions

diff --git a/bindings/perl/Makefile.PL b/bindings/perl/Makefile.PL
index 0a46d2e0..ddcc0067 100644
--- a/bindings/perl/Makefile.PL
+++ b/bindings/perl/Makefile.PL
@@ -21,7 +21,7 @@ WriteMakefile(
     PREREQ_PM         => {}, # e.g., Module::Name => 1.1
     ($] >= 5.005 ?     ## Add these new keywords supported since 5.005
       ( AUTHOR         => 'Benjamin Dauvergne <bdauvergne@entrouvert.com>') : ()),
-    LIBS              => ["-L$TOP_SRCDIR/lasso/.libs -llasso"], # e.g., '-lm'
+    LIBS              => "-L../../lasso/.libs -llasso", # e.g., '-lm'
     DEFINE            => '', # e.g., '-DHAVE_SOMETHING'
     INC               => "-I. -I$SRCDIR -I$SRCDIR/../.. -I$TOP_BUILDDIR $CFLAGS", # e.g., '-I. -I/usr/include/other'
 	# Un-comment this if you add C files to link with later:
diff --git a/bindings/perl/Makefile.am b/bindings/perl/Makefile.am
index dc354bcf..9a280e19 100644
--- a/bindings/perl/Makefile.am
+++ b/bindings/perl/Makefile.am
@@ -3,6 +3,7 @@ MOSTLYCLEANFILES =
 
 LASSO_XS_CFLAGS = -fno-strict-aliasing $(LASSO_CFLAGS) $(LASSO_CORE_CFLAGS) $(PERL_CFLAGS) $(AM_CFLAGS)
 
+TESTS_ENVIRONMENT=TOP_SRCDIR=$(top_srcdir)
 TESTS = test.sh
 
 if PERL_ENABLED
@@ -20,13 +21,13 @@ EXTRA_ARGS = --enable-id-wsf
 endif
 
 Makefile.perl: $(srcdir)/Makefile.PL Lasso.xs Lasso.pm
-	CFLAGS="$(LASSO_XS_CFLAGS)" TOP_BUILDDIR="$(top_builddir)" \
-	       SRCDIR="$(srcdir)" BUILDDIR=./ $(PERL) $(srcdir)/Makefile.PL PREFIX=$(prefix)
-
 	-if [ "$(srcdir)" != "$(builddir)" ]; then \
 		cp -R $(srcdir)/t $(srcdir)/test.pl $(srcdir)/Makefile.PL $(srcdir)/LassoNode.xs .; \
 		chmod -R u+rwx t test.pl Makefile.PL LassoNode.xs; \
 	fi
+	CFLAGS="$(LASSO_XS_CFLAGS)" TOP_BUILDDIR="$(top_builddir)" \
+	       SRCDIR="$(srcdir)" BUILDDIR=./ $(PERL) Makefile.PL PREFIX=$(prefix)
+
 
 Lasso.xs Lasso.pm: lang.py typemap-in typemap-out
 	$(PYTHON) $(top_srcdir)/bindings/bindings.py -l perl --src-dir=$(top_srcdir)/lasso/ $(EXTRA_ARGS)
diff --git a/bindings/perl/ghashtable_handling.c b/bindings/perl/ghashtable_handling.c
new file mode 100644
index 00000000..b49ed9f5
--- /dev/null
+++ b/bindings/perl/ghashtable_handling.c
@@ -0,0 +1,117 @@
+/*
+ * Lasso - A free implementation of the Liberty Alliance specifications.
+ *
+ * Copyright (C) 2004-2007 Entr'ouvert
+ * http://lasso.entrouvert.org
+ *
+ * Authors: See AUTHORS file in top-level directory.
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2 of the License, or
+ * (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+ *
+ */
+
+#include <perl.h>
+#include <glib.h>
+#include <glib-object.h>
+#include <lasso/xml/xml.h>
+#include <lasso/utils.h>
+
+/**
+ * set_hash_of_strings:
+ * @hash: a #GHashTable variable
+ * @hv: a perl hash
+ */
+void
+set_hash_of_strings(GHashTable **hash, HV *hv)
+{
+	SV *data;
+	char *key;
+	I32 len;
+
+	g_hash_table_remove_all(*hash);
+	hv_iterinit(hv);
+	while ((data = hv_iternextsv(hv, &key, &len))) {
+		if (SvTYPE(data) != SVt_PV) {
+			croak("hash contains non-strings values");
+		}
+	}
+	hv_iterinit(hv);
+	while ((data = hv_iternextsv(hv, &key, &len))) {
+		g_hash_table_insert(*hash, g_strndup(key, len), g_strdup(SvPV_nolen(data)));
+	}
+}
+
+/**
+ * set_hash_of_objects:
+ * @hash: a #GHashTable variable
+ * @hv: a perl hash
+ */
+void
+set_hash_of_objects(GHashTable **hash, HV *hv)
+{
+	SV *data;
+	char *key;
+	I32 len;
+
+	g_hash_table_remove_all(*hash);
+	hv_iterinit(hv);
+	while ((data = hv_iternextsv(hv, &key, &len))) {
+		if (! gperl_get_object(data)) {
+			croak("hash contains non-strings values");
+		}
+	}
+	hv_iterinit(hv);
+	while ((data = hv_iternextsv(hv, &key, &len))) {
+		g_hash_table_insert(*hash, g_strndup(key, len), g_object_ref(data));
+	}
+}
+
+/**
+ * get_hash_of_strings:
+ * @hash: a #GHashTable of strings
+ */
+HV*
+get_hash_of_strings(GHashTable *hash)
+{
+	GHashTableIter iter;
+	gpointer key, value;
+	HV *hv;
+
+	hv = newHV();
+	g_hash_table_iter_init(&iter, hash);
+	while (g_hash_table_iter_next(&iter, &key, &value)) {
+		(void)hv_store(hv, key, strlen(key), newSVpv(value, 0), 0);
+	}
+	return hv;
+}
+
+/**
+ * get_hash_of_objects:
+ * @hash: a #GHashTable of objects
+ */
+HV*
+get_hash_of_objects(GHashTable *hash)
+{
+	GHashTableIter iter;
+	gpointer key, value;
+	HV *hv;
+
+	hv = newHV();
+	g_hash_table_iter_init(&iter, hash);
+	while (g_hash_table_iter_next(&iter, &key, &value)) {
+		(void)hv_store(hv, key, strlen(key), gperl_new_object(value, FALSE), 0);
+	}
+	return hv;
+}
diff --git a/bindings/perl/gobject_handling.c b/bindings/perl/gobject_handling.c
index 8e811302..67ba386a 100644
--- a/bindings/perl/gobject_handling.c
+++ b/bindings/perl/gobject_handling.c
@@ -43,7 +43,7 @@ extern int lasso_init();
 
 void
 init_perl_lasso() {
-	type_to_package = g_hash_table_new_full(g_int_hash, g_int_equal, NULL, g_free);
+	type_to_package = g_hash_table_new_full(g_direct_hash, g_direct_equal, NULL, g_free);
 	wrapper_quark = g_quark_from_static_string("PerlLasso::wrapper");
 	lasso_init();
 }
@@ -58,6 +58,7 @@ gperl_object_package_from_type (GType gtype)
 		!g_type_is_a (gtype, G_TYPE_INTERFACE))
 		return NULL;
 
+
 	package = g_hash_table_lookup(type_to_package, (gconstpointer)gtype);
 	if (package)
 		return package;
@@ -112,7 +113,7 @@ update_wrapper (GObject *object, gpointer obj)
                                  (GDestroyNotify)gobject_destroy_wrapper);
 }
 
-SV *
+static SV *
 gperl_new_object (GObject * object,
                   gboolean own)
 {
@@ -212,7 +213,7 @@ gperl_new_object (GObject * object,
 	return sv;
 }
 
-GObject *
+static GObject *
 gperl_get_object (SV * sv)
 {
 	MAGIC *mg;
@@ -225,3 +226,21 @@ gperl_get_object (SV * sv)
 		return NULL;
 	return (GObject *) mg->mg_ptr;
 }
+
+static void
+gperl_lasso_error(int error)
+{
+	if (error != 0) {
+		HV *hv;
+		SV *sv;
+		char *what = Nullch;
+
+		const char *desc = lasso_strerror(error);
+		hv = newHV();
+		(void)hv_store(hv, "code", 4, newSViv(error), 0);
+		(void)hv_store(hv, "message", 7, newSVpv(desc, 0), 0);
+		sv = sv_bless(newRV_noinc((SV*)hv), gv_stashpv("Lasso::Error", TRUE));
+		sv_setsv(ERRSV, sv);
+		croak ((void*)what);
+	}
+}
diff --git a/bindings/perl/lang.py b/bindings/perl/lang.py
index 06ca9bbc..022fcc60 100644
--- a/bindings/perl/lang.py
+++ b/bindings/perl/lang.py
@@ -93,6 +93,8 @@ class Binding:
     def generate_typemap(self):
         self.typemap.pn('TYPEMAP')
         self.typemap.pn('''
+string_or_null\tT_STRING_OR_NULL
+string_non_null\tT_STRING_NON_NULL
 const gchar *\tT_PV
 gchar *\tT_PV
 gboolean\tT_IV
@@ -128,7 +130,7 @@ GHashTable*\tT_PTRREF
         for struct in self.binding_data.structs:
             if struct.name != 'LassoNode':
                 self.pm.pn('package Lasso::%s;' % struct.name[5:])
-                self.pm.pn('our @ISA = qw(%s);' % struct.parent[5:])
+                self.pm.pn('our @ISA = qw(Lasso::%s);' % struct.parent[5:])
                 self.pm.pn()
 
     def generate_xs_header(self):
@@ -139,11 +141,14 @@ GHashTable*\tT_PTRREF
 #include "XSUB.h"
 #include <stdio.h>
 
-#include "gobject_handling.c"
-#include "glist_handling.c"
+#include "./gobject_handling.c"
+#include "./glist_handling.c"
+#include "./ghashtable_handling.c"
 
 #define lasso_assign_simple(a,b) a = b;
 
+typedef char* string_non_null;
+typedef char* string_or_null;
 typedef GList* GList_string;
 typedef GList* GList_gobject;
 typedef GList* GList_xmlnode;
@@ -171,27 +176,42 @@ INCLUDE: LassoNode.xs
     HV *stash;
 
     init_perl_lasso();
-    stash = gv_stashpv("Lasso", 1);''')
+    stash = gv_stashpv("Lasso::Constants", 1);''')
         self.xs.indent()
         for constant in self.binding_data.constants:
             type, name = constant
             perl_name = name[6:]
-            self.xs.pn('ct = get_sv("Lasso::Constants::%s", TRUE | GV_ADDMULTI);' % perl_name)
-            if type == 'i':
-                self.xs.pn('sv_setiv(ct, %s);' % name)
-            elif type == 's':
-                self.xs.pn('sv_setpv(ct, %s);' % name)
-            elif type == 'b': # only one case LASSO_WSF_ENABLED
-                self.xs.unindent()
-                self.xs.pn('''#ifdef %s
-    sv_setiv(ct, 1);
+            if False:
+                self.xs.pn('ct = get_sv("Lasso::Constants::%s", TRUE | GV_ADDMULTI);' % perl_name)
+                if type == 'i':
+                    self.xs.pn('sv_setiv(ct, %s);' % name)
+                elif type == 's':
+                    self.xs.pn('sv_setpv(ct, %s);' % name)
+                elif type == 'b': # only one case LASSO_WSF_ENABLED
+                    self.xs.unindent()
+                    self.xs.pn('''#ifdef %s
+        sv_setiv(ct, 1);
+    #else
+        sv_setiv(ct, 0);
+    #endif''' % name)
+                    self.xs.indent()
+                else:
+                    raise Exception('Unknown constant type: type: "%s" name: "%s"' % (type,name))
+                self.xs.pn('SvREADONLY_on (ct);')
+            else:
+                if type == 'i':
+                    self.xs.pn('ct = newSViv(%s);' % name)
+                elif type == 's':
+                    self.xs.pn('ct = newSVpv(%s, 0);' % name)
+                elif type == 'b': # only one case LASSO_WSF_ENABLED
+                    self.xs.unindent()
+                    self.xs.pn('''#ifdef %s
+        ct = newSViv(1);
 #else
-    sv_setiv(ct, 0);
+        ct = newSViv(0);
 #endif''' % name)
-                self.xs.indent()
-            else:
-                raise Exception('Unknown constant type: type: "%s" name: "%s"' % (type,name))
-            self.xs.pn('SvREADONLY_on (ct);')
+                    self.xs.indent()
+                self.xs.pn('newCONSTSUB(stash, "%s", ct);' % perl_name)
         self.xs.unindent()
         self.xs.pn('}')
 
@@ -217,6 +237,15 @@ INCLUDE: LassoNode.xs
         klassname = clss.name
         pass
 
+    def default_value(self, arg):
+        default = arg_default(arg)
+        if default[0] == 'b':
+            return default[2:]
+        elif default[0] == 'c':
+            return default[2:]
+        else:
+            raise Exception('Unknown default value for %s' % (arg,))
+
     def generate_xs_function(self, func):
         name = func.name
         if 'get_nameIden' in name:
@@ -232,13 +261,35 @@ INCLUDE: LassoNode.xs
                 raise
         self.xs.p(name + '(')
         arg_list = []
+        if name.endswith('_new'):
+            arg_list.append('SV *cls')
         for arg in func.args:
-            if not is_glist(arg):
-                arg_list.append('%s %s' % (arg_type(arg), arg_name(arg)))
-            elif is_glist(arg):
-                arg_list.append('%s %s' % (self.glist_type(arg), arg_name(arg)))
+            decl = ''
+            if is_cstring(arg):
+                if is_optional(arg):
+                    decl = 'string_or_null %s' % arg_name(arg)
+                else:
+                    decl = 'string_non_null %s' % arg_name(arg)
+            elif not is_glist(arg):
+                decl = '%s %s' % (arg_type(arg), arg_name(arg))
+            else:
+                decl = '%s %s' % (self.glist_type(arg), arg_name(arg))
+            if is_optional(arg):
+                if arg_default(arg):
+                    decl += ' = ' + self.default_value(arg)
+                else:
+                    if is_cstring(arg) or is_glist(arg):
+                        decl += ' = NULL'
+                    else:
+                        raise Exception('Do not know what to do for optional: %s' % arg)
+            arg_list.append(decl)
         self.xs.p(','.join(arg_list))
         self.xs.pn(')')
+        if name.endswith('_new'):
+            self.xs.pn('  INIT:')
+            self.xs.pn('    cls = NULL;')
+            self.xs.pn('  C_ARGS:')
+            self.xs.pn('    ' + ', '.join([arg_name(arg) for arg in func.args]))
         need_prototype = False
         for x in func.args:
             if is_glist(x):
@@ -247,6 +298,8 @@ INCLUDE: LassoNode.xs
             self.xs.p('PROTOTYPE: ')
             optional = False
             proto = []
+            if name.endswith('_new'):
+                proto.append('$')
             for arg in func.args:
                 if is_optional(arg) and not optional:
                     proto.append(';')
@@ -269,6 +322,9 @@ INCLUDE: LassoNode.xs
         elif func.return_type and is_object(func.return_type) and not is_int(func.return_type, self.binding_data) and func.return_owner:
             self.xs.pn('''   CLEANUP:
          g_object_unref(RETVAL);''')
+        elif is_int(func.return_arg, self.binding_data):
+            self.xs.pn('''   CLEANUP:
+         gperl_lasso_error(RETVAL);''')
 
     def generate_xs_getter_setter(self, struct, member):
         name = arg_name(member)
@@ -320,7 +376,32 @@ INCLUDE: LassoNode.xs
                 'release': self.release_list('obj', member),
                 })
         elif is_hashtable(member):
-            print >>sys.stderr, 'W: skipping %(cls)s.%(name)s, GHashtable fields are not supported for the momement' % { 'cls': struct.name, 'name': arg_name(member) }
+            if is_object(element_type(member)):
+                kind = "objects"
+            else:
+                kind = "strings"
+            self.xs.pn('''
+HV*
+%(field)s(%(clss)s* obj, ...)
+    PROTOTYPE:
+        $;\%%
+    CODE:
+        if (items > 1) { /* setter */
+            if (SvTYPE(ST(1)) != SVt_RV || ! SvTYPE(SvRV(ST(1))) != SVt_PVHV) {
+                sv_dump(ST(1));
+                croak("Lasso::%(klass)s::%(field)s takes a reference to a hash as argument");
+            }
+            set_hash_of_%(kind)s(&obj->%(field)s, (HV*)SvRV(ST(1)));
+        }
+        RETVAL = get_hash_of_%(kind)s(obj->%(field)s);
+        sv_2mortal((SV*)RETVAL);
+    OUTPUT:
+        RETVAL
+''' % { 'kind': kind,
+            'field': name, 
+            'clss': struct.name,
+            'klass': struct.name[5:]
+                })
 
     def starify(self, str):
         if '*' in str:
diff --git a/bindings/perl/t/Lasso.t b/bindings/perl/t/Lasso.t
index 73d7abf5..9aa05301 100644..100755
--- a/bindings/perl/t/Lasso.t
+++ b/bindings/perl/t/Lasso.t
@@ -5,11 +5,36 @@
 
 # change 'tests => 1' to 'tests => last_test_to_print';
 
-use Test::More tests => 1;
-BEGIN { use_ok('Lasso') };
+use Test::More tests => 8;
+use Lasso;
+use Data::Dumper;
+use Error qw(:try);
 
 #########################
+my $SRCDIR = $ENV{'TOP_SRCDIR'};
 
 # Insert your test code below, the Test::More module is use()ed here so read
 # its man page ( perldoc Test::More ) for help writing this test script.
 
+# Test arrays
+$request = new Lasso::SamlpRequest();
+ok (! defined($request->RespondWith));
+Lasso::SamlpRequestAbstract::RespondWith($request, "x", "y", "z");
+@l = $request->RespondWith;
+ok(@l == 3);
+ok($l[0] eq 'x');
+ok($l[1] eq 'y');
+ok($l[2] eq 'z');
+
+$server = new Lasso::Server($SRCDIR . "/tests/data/sp5-saml2/metadata.xml", $SRCDIR . "/tests/data/sp5-saml2/private-key.pem");
+ok($server);
+$server->add_provider(Lasso::Constants::PROVIDER_ROLE_SP, $SRCDIR . "/tests/data/idp5-saml2/metadata.xml");
+$login = new Lasso::Login $server;
+
+# Test error reporting
+eval { $login->init_authn_request; };
+ok($@->{code} == -409);
+
+$server = new Lasso::Server($SRCDIR . "/tests/data/sp5-saml2/metadata.xml", $SRCDIR . "/tests/data/sp5-saml2/private-key.pem");
+ok($server);
+$server->add_provider(Lasso::Constants::PROVIDER_ROLE_IDP, $SRCDIR . "/tests/data/idp5-saml2/metadata.xml");
diff --git a/bindings/perl/test.sh b/bindings/perl/test.sh
index e5a0465e..907080d1 100755
--- a/bindings/perl/test.sh
+++ b/bindings/perl/test.sh
@@ -1,3 +1,2 @@
 #!/bin/bash
-
 make -f Makefile.perl test
diff --git a/bindings/perl/typemap-in b/bindings/perl/typemap-in
index b98c4295..b6eede9c 100644
--- a/bindings/perl/typemap-in
+++ b/bindings/perl/typemap-in
@@ -1,4 +1,9 @@
 INPUT
+T_STRING_OR_NULL
+    $var = SvPOK($arg) ? SvPV_nolen($arg) : NULL;
+
+T_STRING_NON_NULL
+    $var = SvPOK($arg) ? SvPV_nolen($arg) : (croak(\"$var cannot be undef\"), NULL);
 
 T_GOBJECT_WRAPPER
     $var = ($type)gperl_get_object($arg);
diff --git a/bindings/perl/typemap-out b/bindings/perl/typemap-out
index 6327b6ad..6ed7022e 100644
--- a/bindings/perl/typemap-out
+++ b/bindings/perl/typemap-out
@@ -18,6 +18,10 @@ T_GLIST_STRING
           ST(ix) = sv_2mortal(newSVpv((char*)$var->data, 0));
           $var = $var->next;
       }
+      if (length)
+          XSRETURN(length);
+      else
+          XSRETURN_EMPTY;
     }
 
 T_GLIST_XMLNODE
@@ -29,6 +33,10 @@ T_GLIST_XMLNODE
           ST(ix) = sv_2mortal(xmlnode_to_pv((xmlNode*)$var->data, FALSE));
           $var = $var->next;
       }
+      if (length)
+          XSRETURN(length);
+      else
+          XSRETURN_EMPTY;
     }
 
 T_GLIST_GOBJECT
@@ -40,4 +48,8 @@ T_GLIST_GOBJECT
           ST(ix) = sv_2mortal(gperl_new_object((GObject*)$var->data, FALSE));
           $var = $var->next;
       }
+      if (length)
+          XSRETURN(length);
+      else
+          XSRETURN_EMPTY;
     }