first cut at procedures

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 18ee763..4e4ea5f 100755 (executable)
--- a/Open-ILS/src/sql/Pg/make-pgtap-tests.pl
+++ b/Open-ILS/src/sql/Pg/make-pgtap-tests.pl
@@ -64,6 +64,10 @@ handle_schemas(
             \&handle_table_things
         );
 
+        handle_routines(
+            $schema,
+            undef
+        );
     }
 );
 print pgtap_sql_footer();
@@ -194,6 +198,39 @@ sub fetch_triggers {
     return $triggers;
 }
 
+sub fetch_routines {
+    my $schema = shift;
+    my $sth = $dbh->prepare("
+        SELECT
+            *
+        FROM information_schema.routines
+            WHERE routine_catalog = ?
+            AND routine_schema = ?
+    ");
+    $sth->execute(($db_name,$schema));
+    my $triggers = $sth->fetchall_hashref('routine_name');
+    $sth->finish;
+    return $triggers;
+}
+
+sub fetch_parameters {
+    my $schema = shift;
+    my $specific_routine = shift;
+    my $sth = $dbh->prepare("
+        SELECT
+            *
+        FROM information_schema.parameters
+            WHERE specific_catalog = ?
+            AND specific_schema = ?
+            AND specific_name = ?
+            AND parameter_mode = 'IN'
+    ");
+    $sth->execute(($db_name,$schema,$specific_routine));
+    my $parameters = $sth->fetchall_hashref('ordinal_position');
+    $sth->finish;
+    return $parameters;
+}
+
 sub handle_schemas {
     my $callback = shift;
 
@@ -406,4 +443,101 @@ sub handle_triggers {
 
 }
 
+sub handle_routines {
+    my ($schema,$callback) = (shift,shift);
+    if ($schema eq 'evergreen') {
+        return; # TODO: Being the first schema in the search path, evergreen
+                #       gets too polluted with non-EG stuff.  Should maybe
+                #       hand-add evergreen routines once we get going with pgTAP
+    }
+    my $routines = fetch_routines($schema);
+    if (!%{ $routines }) {
+        return;
+    }
+
+    print "\n-- -- routines in schema " . $dbh->quote($schema) . "\n";
+    print "SELECT functions_are(\n";
+    print "\t" . $dbh->quote($schema) . ",\n";
+    print "\tARRAY[\n\t\t";
+    print join(
+        ",\n\t\t",
+        map { $dbh->quote($_) } sort keys %{ $routines }
+    );
+    print "\n\t],\t" . $dbh->quote("Found expected stored procedures for $schema");
+    print "\n);\n";
+
+    foreach my $routine ( sort keys %{ $routines } ) {
+
+        print "\n-- -- routine " . $dbh->quote("$schema.$routine") . "\n";
+
+        my $parameters = fetch_parameters(
+            $schema,
+            $routines->{$routine}->{specific_name}
+        );
+        my @params_array = (); # for trusted order and convenience
+        if (%{ $parameters }) {
+            foreach my $ord ( sort keys %{ $parameters } ) { 
+                $params_array[$ord-1] = $parameters->{$ord}
+            }
+        }
+
+        my $troublesome_parameter = 0;
+        my $args_sig = 'ARRAY[]::TEXT[]';
+        if (scalar(@params_array) > 0) {
+            $args_sig = 'ARRAY[';
+            for (my $i = 0; $i < scalar(@params_array); $i++) {
+                $args_sig .= ($i ? ',' : '') . $dbh->quote( $params_array[$i]->{data_type} );
+                if ( $params_array[$i]->{data_type} eq 'ARRAY' ) {
+                    $troublesome_parameter = 1;
+                }
+                if ( $params_array[$i]->{data_type} eq 'USER-DEFINED' ) {
+                    $troublesome_parameter = 1;
+                }
+            }
+            $args_sig .= ']';
+        }
+        if ($troublesome_parameter) {
+            $args_sig = ''; # this is optional in the assertion functions
+                            # but not sure how it handles similarly named
+                            # routines with different parameter signatures
+        }
+
+        print "SELECT function_lang_is(\n";
+        print "\t" . $dbh->quote($schema) . ",\n";
+        print "\t" . $dbh->quote($routine) . ",\n";
+        print "\t$args_sig,\n" if $args_sig;
+        print "\t" . $dbh->quote(lc($routines->{$routine}->{external_language})) . ",\n";
+        print "\t" . $dbh->quote("$schema.$routine written in $routines->{$routine}->{external_language}") . "\n";
+        print ");\n";
+
+
+        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.
+        if ($data_type eq 'USER-DEFINED') {
+            $data_type = 'setof ' . $routines->{$routine}->{type_udt_schema}
+                . '.' . $routines->{$routine}->{type_udt_name}
+        }
+        if ($data_type eq 'record') {
+            $data_type = 'setof record';
+        }
+
+        print "SELECT function_returns(\n";
+        print "\t" . $dbh->quote($schema) . ",\n";
+        print "\t" . $dbh->quote($routine) . ",\n";
+        print "\t$args_sig,\n" if $args_sig;
+        print "\t" . $dbh->quote($data_type) . ",\n";
+        print "\t" . $dbh->quote("$schema.$routine returns $data_type") . "\n";
+        print ");\n";
+
+        for (my $i = 0; $i < scalar(@params_array); $i++) {
+            print '-- -- -- param ' . $dbh->quote( $params_array[$i]->{parameter_name} ) . "\n";
+        }
+
+        $callback->($schema,$routine,undef) if $callback;
+    }
+}
+