fix up return type testing

Signed-off-by: Jason Etheridge <jason@esilibrary.com>

diff --git a/Open-ILS/src/sql/Pg/make-pgtap-tests.pl b/Open-ILS/src/sql/Pg/make-pgtap-tests.pl
index 4e4ea5f..1aa70b4 100755 (executable)
--- a/Open-ILS/src/sql/Pg/make-pgtap-tests.pl
+++ b/Open-ILS/src/sql/Pg/make-pgtap-tests.pl
@@ -208,9 +208,36 @@ sub fetch_routines {
             AND routine_schema = ?
     ");
     $sth->execute(($db_name,$schema));
-    my $triggers = $sth->fetchall_hashref('routine_name');
+    my $routines = $sth->fetchall_hashref('routine_name');
     $sth->finish;
-    return $triggers;
+    return $routines;
+}
+
+sub fetch_pg_routines { # uses pg_catalog.pg_proc instead of information_schema.routines
+    my $name = shift;
+    my $nargs = shift;
+    my $src = shift;
+    my $sth = $dbh->prepare("
+        SELECT
+            *
+        FROM pg_catalog.pg_proc
+            WHERE proname = ?
+            AND pronargs = ?
+            AND prosrc = ?
+    ");
+    $sth->execute(($name,$nargs,$src));
+    my $routines = $sth->fetchall_hashref([ qw(proname proargtypes pronamespace) ]);
+    $sth->finish;
+    my @rows = ();
+    foreach my $proname ( keys %{ $routines } ) {
+        foreach my $proargtypes ( keys %{ $routines->{$proname} } ) {
+            foreach my $pronamespace ( keys %{ $routines->{$proname}->{$proargtypes} } ) {
+                push @rows, $routines->{$proname}->{$proargtypes}->{$pronamespace};
+            }
+        }
+    }
+
+    return @rows;
 }
 
 sub fetch_parameters {
@@ -512,17 +539,37 @@ sub handle_routines {
 
 
         my $data_type = $routines->{$routine}->{data_type};
-        # The following datatype munging is voodoo to just work with the current
-        # schema.  No promises that it'll always work, but the point of this
-        # script is just to create an initial set of tests; we may never use
-        # again afterward.
+        # The following datatype munging is voodoo/heuristic to just work with
+        # the current schema.  No promises that it'll always work, but the point
+        # of this script is just to create an initial set of tests; we may never
+        # use it again afterward, though I could see it being useful for seeding
+        # tests against whole new schemas/tables as they appear.
         if ($data_type eq 'USER-DEFINED') {
-            $data_type = 'setof ' . $routines->{$routine}->{type_udt_schema}
-                . '.' . $routines->{$routine}->{type_udt_name}
+            $data_type = $routines->{$routine}->{type_udt_schema} . "."
+                . $routines->{$routine}->{type_udt_name};
+            if ($data_type eq 'public.hstore') {
+                $data_type = 'hstore'; # an exception
+            }
+        }
+        if ($data_type eq 'ARRAY') {
+            if ($routines->{$routine}->{type_udt_name} eq '_int4') {
+                $data_type = 'integer[]';
+            } elsif ($routines->{$routine}->{type_udt_name} eq '_text') {
+                $data_type = 'text[]';
+            } else {
+                $data_type = $routines->{$routine}->{type_udt_name} . '[]';
+            }
         }
-        if ($data_type eq 'record') {
-            $data_type = 'setof record';
+        my @extra_data = fetch_pg_routines(
+            $routine,
+            scalar(@params_array),
+            $routines->{$routine}->{routine_definition}
+        );
+        my $expect_set = 0;
+        if (scalar(@extra_data) == 1) {
+           $expect_set = $extra_data[0]->{proretset};
         }
+        $data_type = "setof $data_type" if $expect_set && $data_type ne 'void';
 
         print "SELECT function_returns(\n";
         print "\t" . $dbh->quote($schema) . ",\n";