[open-ils-commits] [GIT] Evergreen ILS branch master updated. d6ec45265c0d1b4b1b9444d3525e0e7e13b646f7
Evergreen Git
git at git.evergreen-ils.org
Thu Aug 1 11:41:43 EDT 2013
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "Evergreen ILS".
The branch, master has been updated
via d6ec45265c0d1b4b1b9444d3525e0e7e13b646f7 (commit)
from 7e8eec68388a661c68970622bccc07711b80fe47 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit d6ec45265c0d1b4b1b9444d3525e0e7e13b646f7
Author: Jason Etheridge <jason at esilibrary.com>
Date: Mon Jul 22 19:03:24 2013 -0400
make-pgtap-tests.pl
For seeding a baseline set of pgTAP tests for Evergreen. By default, assumes
PostgreSQL is running on localhost at port 5432 with a database name of
"evergreen", and with an "evergreen" user configured with password "evergreen".
Command-line options for tweaking these are
-db_name=? -db_host=? -db_port=? -db_user=? -db_pw=?
Make sure to install pgTAP (probably best do it from source for all the
assertion functions we're using) for the database you want to run the tests
against.
I did the following for my test environment:
git clone git://github.com/theory/pgtap.git
cd pgtap
make
make installcheck
sudo make install
Then in my Evergreen database with psql, I did:
CREATE EXTENSION pgtap;
I also installed a CPAN module to get pg_prove:
sudo cpan TAP::Parser::SourceHandler::pgTAP
Signed-off-by: Jason Etheridge <jason at esilibrary.com>
Signed-off-by: Mike Rylander <mrylander at gmail.com>
diff --git a/Open-ILS/src/sql/Pg/make-pgtap-tests.pl b/Open-ILS/src/sql/Pg/make-pgtap-tests.pl
new file mode 100755
index 0000000..e26fd81
--- /dev/null
+++ b/Open-ILS/src/sql/Pg/make-pgtap-tests.pl
@@ -0,0 +1,589 @@
+#!/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;
+ }
+}
+
+
-----------------------------------------------------------------------
Summary of changes:
Open-ILS/src/sql/Pg/make-pgtap-tests.pl | 589 +++++++++++++++++++++++++++++++
1 files changed, 589 insertions(+), 0 deletions(-)
create mode 100755 Open-ILS/src/sql/Pg/make-pgtap-tests.pl
hooks/post-receive
--
Evergreen ILS
More information about the open-ils-commits
mailing list