--- /dev/null
+#!/usr/bin/perl
+# vim:et:ts=4:
+use strict;
+use warnings;
+use Getopt::Long;
+
+my ($db_name, $db_host, $db_port, $db_user, $db_pw) =
+ ( 'evergreen', 'localhost', '5432', 'evergreen', 'evergreen' );
+
+GetOptions(
+ 'db_name=s' => \$db_name,
+ 'db_host=s' => \$db_host,
+ 'db_port=s' => \$db_port,
+ 'db_user=s' => \$db_user,
+ 'db_pw=s' => \$db_pw,
+);
+
+#----------------------------------------------------------
+# Database connection
+#----------------------------------------------------------
+
+use DBI;
+
+my $dsn = "dbi:Pg:dbname=$db_name;host=$db_host;port=$db_port";
+my $dbh = DBI->connect($dsn, $db_user, $db_pw);
+
+# Short-circuit if we didn't connect successfully
+unless($dbh) {
+ warn "* Unable to connect to database $dsn, user=$db_user, password=$db_pw\n";
+ exit 1;
+}
+
+#----------------------------------------------------------
+# Main logic
+#----------------------------------------------------------
+
+print pgtap_sql_header();
+handle_schemas(
+ sub {
+ my $schema = shift;
+
+ sub handle_table_things {
+ my $schema = shift;
+ my $table_or_view = shift;
+ handle_columns(
+ $schema,
+ $table_or_view,
+ undef
+ );
+ handle_triggers(
+ $schema,
+ $table_or_view,
+ undef
+ );
+ }
+
+ handle_tables(
+ $schema,
+ \&handle_table_things
+ );
+ handle_views(
+ $schema,
+ \&handle_table_things
+ );
+
+ handle_routines(
+ $schema,
+ undef
+ );
+ }
+);
+print pgtap_sql_footer();
+
+$dbh->disconnect;
+exit 0;
+
+#----------------------------------------------------------
+# subroutines
+#----------------------------------------------------------
+
+sub pgtap_sql_header {
+ return q^
+\set ECHO
+\set QUIET 1
+-- Turn off echo and keep things quiet.
+
+-- Format the output for nice TAP.
+\pset format unaligned
+\pset tuples_only true
+\pset pager
+
+-- Revert all changes on failure.
+\set ON_ERROR_ROLLBACK 1
+\set ON_ERROR_STOP true
+\set QUIET 1
+
+-- Load the TAP functions.
+BEGIN;
+
+-- Plan the tests.
+SELECT no_plan();
+
+-- Run the tests.
+^;
+}
+
+sub pgtap_sql_footer {
+ return q^
+-- Finish the tests and clean up.
+SELECT * FROM finish();
+ROLLBACK;
+^;
+}
+
+sub fetch_schemas {
+ my $sth = $dbh->prepare("
+ SELECT schema_name FROM information_schema.schemata
+ WHERE catalog_name = ?
+ AND schema_name NOT IN ('information_schema','migration_tools','public')
+ AND schema_name !~ '^pg_';
+ ");
+ $sth->execute(($db_name));
+ my $schemas = $sth->fetchall_arrayref([0]);
+ $sth->finish;
+ return sort map { $_->[0] } @{ $schemas };
+}
+
+sub fetch_tables {
+ my $schema = shift;
+ my $sth = $dbh->prepare("
+ SELECT table_name FROM information_schema.tables
+ WHERE table_catalog = ?
+ AND table_schema = ?
+ AND table_type = 'BASE TABLE'
+ ");
+ $sth->execute(($db_name,$schema));
+ my $tables = $sth->fetchall_arrayref([0]);
+ $sth->finish;
+ return sort map { $_->[0] } @{ $tables };
+}
+
+sub fetch_views {
+ my $schema = shift;
+ my $sth = $dbh->prepare("
+ SELECT table_name FROM information_schema.tables
+ WHERE table_catalog = ?
+ AND table_schema = ?
+ AND table_type = 'VIEW'
+ ");
+ $sth->execute(($db_name,$schema));
+ my $tables = $sth->fetchall_arrayref([0]);
+ $sth->finish;
+ return sort map { $_->[0] } @{ $tables };
+}
+
+sub fetch_columns {
+ my ($schema,$table) = (shift,shift);
+ my $sth = $dbh->prepare("
+ SELECT
+ column_name,
+ data_type,
+ is_nullable,
+ column_default,
+ numeric_precision,
+ numeric_scale,
+ udt_schema,
+ udt_name,
+ character_maximum_length
+ FROM information_schema.columns
+ WHERE table_catalog = ?
+ AND table_schema = ?
+ AND table_name = ?
+ ");
+ $sth->execute(($db_name,$schema,$table));
+ my $columns = $sth->fetchall_hashref('column_name');
+ $sth->finish;
+ return $columns;
+}
+
+sub fetch_triggers {
+ my ($schema,$table) = (shift,shift);
+ my $sth = $dbh->prepare("
+ SELECT DISTINCT
+ trigger_schema,
+ trigger_name,
+ event_object_schema,
+ event_object_table
+ FROM information_schema.triggers
+ WHERE event_object_catalog = ?
+ AND event_object_schema = ?
+ AND event_object_table = ?
+ AND trigger_schema = event_object_schema -- I don't think pgTAP can handle it otherwise
+ ");
+ $sth->execute(($db_name,$schema,$table));
+ my $triggers = $sth->fetchall_hashref('trigger_name');
+ $sth->finish;
+ 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 $routines = $sth->fetchall_hashref('routine_name');
+ $sth->finish;
+ 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 {
+ 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;
+
+ my @schemas = fetch_schemas();
+ foreach my $schema ( @schemas ) {
+ print "\n-- schema " . $dbh->quote($schema) . "\n\n";
+ print "SELECT has_schema(\n";
+ print "\t" . $dbh->quote($schema) . ",\n";
+ print "\t" . $dbh->quote("Has schema $schema") . "\n);\n";
+ $callback->($schema) if $callback;
+ }
+}
+
+sub handle_tables {
+ my $schema = shift;
+ my $callback = shift;
+
+ my @tables = fetch_tables($schema);
+ if (scalar @tables == 0) {
+ return;
+ }
+
+ print "SELECT tables_are(\n";
+ print "\t" . $dbh->quote($schema) . ",\n";
+ print "\tARRAY[\n\t\t";
+ print join(
+ ",\n\t\t",
+ map { $dbh->quote($_) } @tables
+ );
+ print "\n\t],\t" . $dbh->quote("Found expected tables for schema $schema");
+ print "\n);\n";
+
+ foreach my $table ( @tables ) {
+ print "\n-- -- table " . $dbh->quote("$schema.$table") . "\n\n";
+ $callback->($schema,$table) if $callback;
+ }
+}
+
+sub handle_views {
+ my $schema = shift;
+ my $callback = shift;
+
+ my @views = fetch_views($schema);
+ if (scalar @views == 0) {
+ return;
+ }
+
+ print "SELECT views_are(\n";
+ print "\t" . $dbh->quote($schema) . ",\n";
+ print "\tARRAY[\n\t\t";
+ print join(
+ ",\n\t\t",
+ map { $dbh->quote($_) } @views
+ );
+ print "\n\t],\t" . $dbh->quote("Found expected views for schema $schema");
+ print "\n);\n";
+
+ foreach my $view ( @views ) {
+ print "\n-- -- view " . $dbh->quote("$schema.$view") . "\n\n";
+ $callback->($schema,$view) if $callback;
+ }
+}
+
+sub handle_columns {
+ my ($schema,$table,$callback) = (shift,shift,shift);
+ my $columns = fetch_columns($schema,$table);
+ if (!%{ $columns }) {
+ return;
+ }
+
+ print "SELECT columns_are(\n";
+ print "\t" . $dbh->quote($schema) . ",\n";
+ print "\t" . $dbh->quote($table) . ",\n";
+ print "\tARRAY[\n\t\t";
+ print join(
+ ",\n\t\t",
+ map { $dbh->quote($_) } sort keys %{ $columns }
+ );
+ print "\n\t],\t" . $dbh->quote("Found expected columns for $schema.$table");
+ print "\n);\n";
+
+ foreach my $column ( sort keys %{ $columns } ) {
+
+ $callback->($schema,$table,$column,undef) if $callback;
+
+ my $col_type_original = $columns->{$column}->{data_type};
+ my $col_type = $col_type_original;
+ my $col_nullable = $columns->{$column}->{is_nullable};
+ my $col_default = $columns->{$column}->{column_default};
+ my $col_numeric_precision = $columns->{$column}->{numeric_precision};
+ my $col_numeric_scale = $columns->{$column}->{numeric_scale};
+ my $col_udt_schema = $columns->{$column}->{udt_schema};
+ my $col_udt_name = $columns->{$column}->{udt_name};
+ my $col_character_maximum_length = $columns->{$column}->{character_maximum_length};
+
+ if (defined $col_default && $col_default =~ /::text/) {
+ $col_default =~ s/^'(.*)'::text$/$1/;
+ }
+ if (defined $col_default && $col_default =~ /::bpchar/) {
+ $col_default =~ s/^'(.*)'::bpchar$/$1/;
+ }
+ if ($col_type eq 'numeric' && defined $col_numeric_precision) {
+ $col_type .= "($col_numeric_precision";
+ if (defined $col_numeric_scale) {
+ $col_type .= ",$col_numeric_scale";
+ }
+ $col_type .= ')';
+ }
+ if ($col_type eq 'USER-DEFINED' && defined $col_udt_schema) {
+ $col_type = "$col_udt_schema.$col_udt_name";
+ if ($col_type eq 'public.hstore') {
+ $col_type = 'hstore'; # an exception
+ }
+ }
+ if ($col_type eq 'character' && defined $col_character_maximum_length) {
+ $col_type .= "($col_character_maximum_length)";
+ }
+ if ($col_type eq 'ARRAY' && defined $col_udt_name) {
+ $col_type = substr($col_udt_name,1) . '[]';
+ }
+
+ print "\n-- -- -- column " . $dbh->quote("$schema.$table.$column") . "\n\n";
+ print "SELECT col_type_is(\n";
+ print "\t" . $dbh->quote($schema) . ",\n";
+ print "\t" . $dbh->quote($table) . ",\n";
+ print "\t" . $dbh->quote($column) . ",\n";
+ print "\t" . $dbh->quote($col_type) . ",\n";
+ print "\t" . $dbh->quote("Column $schema.$table.$column is type $col_type");
+ print "\n);\n";
+ if ($col_nullable eq 'YES') {
+ print "SELECT col_is_null(\n";
+ print "\t" . $dbh->quote($schema) . ",\n";
+ print "\t" . $dbh->quote($table) . ",\n";
+ print "\t" . $dbh->quote($column) . ",\n";
+ print "\t" . $dbh->quote("Column $schema.$table.$column is nullable");
+ print "\n);\n";
+ } else {
+ print "SELECT col_not_null(\n";
+ print "\t" . $dbh->quote($schema) . ",\n";
+ print "\t" . $dbh->quote($table) . ",\n";
+ print "\t" . $dbh->quote($column) . ",\n";
+ print "\t" . $dbh->quote("Column $schema.$table.$column is not nullable");
+ print "\n);\n";
+ }
+ if (defined $col_default) {
+ my $fixme = '';
+ if ($col_type eq 'interval') {
+ # FIXME - ERROR: invalid input syntax for type interval: "'1 day'::interval"
+ $fixme = '-- FIXME type 1 -- ';
+ } elsif ($col_type eq 'time without time zone') {
+ # FIXME - ERROR: invalid input syntax for type time: "'17:00:00'::time without time zone"
+ $fixme = '-- FIXME type 2 -- ';
+ } elsif ($col_default =~ 'org_unit_custom_tree_purpose') {
+ # FIXME - ERROR: invalid input value for enum actor.org_unit_custom_tree_purpose: "'opac'::actor.org_unit_custom_tree_purpose"
+ $fixme = '-- FIXME type 3 -- ';
+ } elsif ($col_type eq 'integer' && $col_default =~ '\(-?\d+\)') {
+ # FIXME - ERROR: invalid input syntax for integer: "(-1)"
+ $fixme = '-- FIXME type 4 -- ';
+ } elsif ($col_type_original eq 'USER-DEFINED'
+ && (
+ $col_udt_name eq 'hstore'
+ || $col_udt_name eq 'authority_queue_queue_type'
+ || $col_udt_name eq 'bib_queue_queue_type'
+ )
+ ) {
+ # FIXME - ERROR: Unexpected end of string
+ $fixme = '-- FIXME type 5 -- ';
+ }
+ # I would love to SELECT todo past these, but they cause hard failures
+ print $fixme . "SELECT col_default_is(\n";
+ print $fixme . "\t" . $dbh->quote($schema) . ",\n";
+ print $fixme . "\t" . $dbh->quote($table) . ",\n";
+ print $fixme . "\t" . $dbh->quote($column) . ",\n";
+ print $fixme . "\t" . $dbh->quote($col_default) . ",\n";
+ print $fixme . "\t" . $dbh->quote("Column $schema.$table.$column has default value: $col_default");
+ print "\n$fixme);\n";
+ } else {
+ print "SELECT col_hasnt_default(\n";
+ print "\t" . $dbh->quote($schema) . ",\n";
+ print "\t" . $dbh->quote($table) . ",\n";
+ print "\t" . $dbh->quote($column) . ",\n";
+ print "\t" . $dbh->quote("Column $schema.$table.$column has no default value");
+ print "\n);\n";
+ }
+ }
+}
+
+sub handle_triggers {
+ my ($schema,$table,$callback) = (shift,shift,shift);
+ my $triggers = fetch_triggers($schema,$table);
+ if (!%{ $triggers }) {
+ return;
+ }
+
+ print "\n-- -- -- triggers on " . $dbh->quote("$schema.$table") . "\n";
+ print "SELECT triggers_are(\n";
+ print "\t" . $dbh->quote($schema) . ",\n";
+ print "\t" . $dbh->quote($table) . ",\n";
+ print "\tARRAY[\n\t\t";
+ print join(
+ ",\n\t\t",
+ map { $dbh->quote($_) } sort keys %{ $triggers }
+ );
+ print "\n\t],\t" . $dbh->quote("Found expected triggers for $schema.$table");
+ print "\n);\n";
+
+ foreach my $trigger ( sort keys %{ $triggers } ) {
+ $callback->($schema,$table,$trigger,undef) if $callback;
+ }
+
+}
+
+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/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 = $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} . '[]';
+ }
+ }
+ 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";
+ 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;
+ }
+}
+
+
projects / evergreen / pines.git / commitdiff