7 my ($db_name, $db_host, $db_port, $db_user, $db_pw) =
8 ( 'evergreen', 'localhost', '5432', 'evergreen', 'evergreen' );
11 'db_name=s' => \$db_name,
12 'db_host=s' => \$db_host,
13 'db_port=s' => \$db_port,
14 'db_user=s' => \$db_user,
18 #----------------------------------------------------------
20 #----------------------------------------------------------
24 my $dsn = "dbi:Pg:dbname=$db_name;host=$db_host;port=$db_port";
25 my $dbh = DBI->connect($dsn, $db_user, $db_pw);
27 # Short-circuit if we didn't connect successfully
29 warn "* Unable to connect to database $dsn, user=$db_user, password=$db_pw\n";
33 #----------------------------------------------------------
35 #----------------------------------------------------------
37 print pgtap_sql_header();
42 sub handle_table_things {
44 my $table_or_view = shift;
72 print pgtap_sql_footer();
77 #----------------------------------------------------------
79 #----------------------------------------------------------
81 sub pgtap_sql_header {
85 -- Turn off echo and keep things quiet.
87 -- Format the output for nice TAP.
88 \pset format unaligned
89 \pset tuples_only true
92 -- Revert all changes on failure.
93 \set ON_ERROR_ROLLBACK 1
94 \set ON_ERROR_STOP true
97 -- Load the TAP functions.
107 sub pgtap_sql_footer {
109 -- Finish the tests and clean up.
110 SELECT * FROM finish();
116 my $sth = $dbh->prepare("
117 SELECT schema_name FROM information_schema.schemata
118 WHERE catalog_name = ?
119 AND schema_name NOT IN ('information_schema','migration_tools','public')
120 AND schema_name !~ '^pg_';
122 $sth->execute(($db_name));
123 my $schemas = $sth->fetchall_arrayref([0]);
125 return sort map { $_->[0] } @{ $schemas };
130 my $sth = $dbh->prepare("
131 SELECT table_name FROM information_schema.tables
132 WHERE table_catalog = ?
134 AND table_type = 'BASE TABLE'
136 $sth->execute(($db_name,$schema));
137 my $tables = $sth->fetchall_arrayref([0]);
139 return sort map { $_->[0] } @{ $tables };
144 my $sth = $dbh->prepare("
145 SELECT table_name FROM information_schema.tables
146 WHERE table_catalog = ?
148 AND table_type = 'VIEW'
150 $sth->execute(($db_name,$schema));
151 my $tables = $sth->fetchall_arrayref([0]);
153 return sort map { $_->[0] } @{ $tables };
157 my ($schema,$table) = (shift,shift);
158 my $sth = $dbh->prepare("
168 character_maximum_length
169 FROM information_schema.columns
170 WHERE table_catalog = ?
174 $sth->execute(($db_name,$schema,$table));
175 my $columns = $sth->fetchall_hashref('column_name');
181 my ($schema,$table) = (shift,shift);
182 my $sth = $dbh->prepare("
188 FROM information_schema.triggers
189 WHERE event_object_catalog = ?
190 AND event_object_schema = ?
191 AND event_object_table = ?
192 AND trigger_schema = event_object_schema -- I don't think pgTAP can handle it otherwise
194 $sth->execute(($db_name,$schema,$table));
195 my $triggers = $sth->fetchall_hashref('trigger_name');
202 my $sth = $dbh->prepare("
205 FROM information_schema.routines
206 WHERE routine_catalog = ?
207 AND routine_schema = ?
209 $sth->execute(($db_name,$schema));
210 my $routines = $sth->fetchall_hashref('routine_name');
215 sub fetch_pg_routines { # uses pg_catalog.pg_proc instead of information_schema.routines
219 my $sth = $dbh->prepare("
222 FROM pg_catalog.pg_proc
227 $sth->execute(($name,$nargs,$src));
228 my $routines = $sth->fetchall_hashref([ qw(proname proargtypes pronamespace) ]);
231 foreach my $proname ( keys %{ $routines } ) {
232 foreach my $proargtypes ( keys %{ $routines->{$proname} } ) {
233 foreach my $pronamespace ( keys %{ $routines->{$proname}->{$proargtypes} } ) {
234 push @rows, $routines->{$proname}->{$proargtypes}->{$pronamespace};
242 sub fetch_parameters {
244 my $specific_routine = shift;
245 my $sth = $dbh->prepare("
248 FROM information_schema.parameters
249 WHERE specific_catalog = ?
250 AND specific_schema = ?
251 AND specific_name = ?
252 AND parameter_mode = 'IN'
254 $sth->execute(($db_name,$schema,$specific_routine));
255 my $parameters = $sth->fetchall_hashref('ordinal_position');
261 my $callback = shift;
263 my @schemas = fetch_schemas();
264 foreach my $schema ( @schemas ) {
265 print "\n-- schema " . $dbh->quote($schema) . "\n\n";
266 print "SELECT has_schema(\n";
267 print "\t" . $dbh->quote($schema) . ",\n";
268 print "\t" . $dbh->quote("Has schema $schema") . "\n);\n";
269 $callback->($schema) if $callback;
275 my $callback = shift;
277 my @tables = fetch_tables($schema);
278 if (scalar @tables == 0) {
282 print "SELECT tables_are(\n";
283 print "\t" . $dbh->quote($schema) . ",\n";
284 print "\tARRAY[\n\t\t";
287 map { $dbh->quote($_) } @tables
289 print "\n\t],\t" . $dbh->quote("Found expected tables for schema $schema");
292 foreach my $table ( @tables ) {
293 print "\n-- -- table " . $dbh->quote("$schema.$table") . "\n\n";
294 $callback->($schema,$table) if $callback;
300 my $callback = shift;
302 my @views = fetch_views($schema);
303 if (scalar @views == 0) {
307 print "SELECT views_are(\n";
308 print "\t" . $dbh->quote($schema) . ",\n";
309 print "\tARRAY[\n\t\t";
312 map { $dbh->quote($_) } @views
314 print "\n\t],\t" . $dbh->quote("Found expected views for schema $schema");
317 foreach my $view ( @views ) {
318 print "\n-- -- view " . $dbh->quote("$schema.$view") . "\n\n";
319 $callback->($schema,$view) if $callback;
324 my ($schema,$table,$callback) = (shift,shift,shift);
325 my $columns = fetch_columns($schema,$table);
326 if (!%{ $columns }) {
330 print "SELECT columns_are(\n";
331 print "\t" . $dbh->quote($schema) . ",\n";
332 print "\t" . $dbh->quote($table) . ",\n";
333 print "\tARRAY[\n\t\t";
336 map { $dbh->quote($_) } sort keys %{ $columns }
338 print "\n\t],\t" . $dbh->quote("Found expected columns for $schema.$table");
341 foreach my $column ( sort keys %{ $columns } ) {
343 $callback->($schema,$table,$column,undef) if $callback;
345 my $col_type_original = $columns->{$column}->{data_type};
346 my $col_type = $col_type_original;
347 my $col_nullable = $columns->{$column}->{is_nullable};
348 my $col_default = $columns->{$column}->{column_default};
349 my $col_numeric_precision = $columns->{$column}->{numeric_precision};
350 my $col_numeric_scale = $columns->{$column}->{numeric_scale};
351 my $col_udt_schema = $columns->{$column}->{udt_schema};
352 my $col_udt_name = $columns->{$column}->{udt_name};
353 my $col_character_maximum_length = $columns->{$column}->{character_maximum_length};
355 if (defined $col_default && $col_default =~ /::text/) {
356 $col_default =~ s/^'(.*)'::text$/$1/;
358 if (defined $col_default && $col_default =~ /::bpchar/) {
359 $col_default =~ s/^'(.*)'::bpchar$/$1/;
361 if ($col_type eq 'numeric' && defined $col_numeric_precision) {
362 $col_type .= "($col_numeric_precision";
363 if (defined $col_numeric_scale) {
364 $col_type .= ",$col_numeric_scale";
368 if ($col_type eq 'USER-DEFINED' && defined $col_udt_schema) {
369 $col_type = "$col_udt_schema.$col_udt_name";
370 if ($col_type eq 'public.hstore') {
371 $col_type = 'hstore'; # an exception
374 if ($col_type eq 'character' && defined $col_character_maximum_length) {
375 $col_type .= "($col_character_maximum_length)";
377 if ($col_type eq 'ARRAY' && defined $col_udt_name) {
378 $col_type = substr($col_udt_name,1) . '[]';
381 print "\n-- -- -- column " . $dbh->quote("$schema.$table.$column") . "\n\n";
382 print "SELECT col_type_is(\n";
383 print "\t" . $dbh->quote($schema) . ",\n";
384 print "\t" . $dbh->quote($table) . ",\n";
385 print "\t" . $dbh->quote($column) . ",\n";
386 print "\t" . $dbh->quote($col_type) . ",\n";
387 print "\t" . $dbh->quote("Column $schema.$table.$column is type $col_type");
389 if ($col_nullable eq 'YES') {
390 print "SELECT col_is_null(\n";
391 print "\t" . $dbh->quote($schema) . ",\n";
392 print "\t" . $dbh->quote($table) . ",\n";
393 print "\t" . $dbh->quote($column) . ",\n";
394 print "\t" . $dbh->quote("Column $schema.$table.$column is nullable");
397 print "SELECT col_not_null(\n";
398 print "\t" . $dbh->quote($schema) . ",\n";
399 print "\t" . $dbh->quote($table) . ",\n";
400 print "\t" . $dbh->quote($column) . ",\n";
401 print "\t" . $dbh->quote("Column $schema.$table.$column is not nullable");
404 if (defined $col_default) {
406 if ($col_type eq 'interval') {
407 # FIXME - ERROR: invalid input syntax for type interval: "'1 day'::interval"
408 $fixme = '-- FIXME type 1 -- ';
409 } elsif ($col_type eq 'time without time zone') {
410 # FIXME - ERROR: invalid input syntax for type time: "'17:00:00'::time without time zone"
411 $fixme = '-- FIXME type 2 -- ';
412 } elsif ($col_default =~ 'org_unit_custom_tree_purpose') {
413 # FIXME - ERROR: invalid input value for enum actor.org_unit_custom_tree_purpose: "'opac'::actor.org_unit_custom_tree_purpose"
414 $fixme = '-- FIXME type 3 -- ';
415 } elsif ($col_type eq 'integer' && $col_default =~ '\(-?\d+\)') {
416 # FIXME - ERROR: invalid input syntax for integer: "(-1)"
417 $fixme = '-- FIXME type 4 -- ';
418 } elsif ($col_type_original eq 'USER-DEFINED'
420 $col_udt_name eq 'hstore'
421 || $col_udt_name eq 'authority_queue_queue_type'
422 || $col_udt_name eq 'bib_queue_queue_type'
425 # FIXME - ERROR: Unexpected end of string
426 $fixme = '-- FIXME type 5 -- ';
428 # I would love to SELECT todo past these, but they cause hard failures
429 print $fixme . "SELECT col_default_is(\n";
430 print $fixme . "\t" . $dbh->quote($schema) . ",\n";
431 print $fixme . "\t" . $dbh->quote($table) . ",\n";
432 print $fixme . "\t" . $dbh->quote($column) . ",\n";
433 print $fixme . "\t" . $dbh->quote($col_default) . ",\n";
434 print $fixme . "\t" . $dbh->quote("Column $schema.$table.$column has default value: $col_default");
435 print "\n$fixme);\n";
437 print "SELECT col_hasnt_default(\n";
438 print "\t" . $dbh->quote($schema) . ",\n";
439 print "\t" . $dbh->quote($table) . ",\n";
440 print "\t" . $dbh->quote($column) . ",\n";
441 print "\t" . $dbh->quote("Column $schema.$table.$column has no default value");
447 sub handle_triggers {
448 my ($schema,$table,$callback) = (shift,shift,shift);
449 my $triggers = fetch_triggers($schema,$table);
450 if (!%{ $triggers }) {
454 print "\n-- -- -- triggers on " . $dbh->quote("$schema.$table") . "\n";
455 print "SELECT triggers_are(\n";
456 print "\t" . $dbh->quote($schema) . ",\n";
457 print "\t" . $dbh->quote($table) . ",\n";
458 print "\tARRAY[\n\t\t";
461 map { $dbh->quote($_) } sort keys %{ $triggers }
463 print "\n\t],\t" . $dbh->quote("Found expected triggers for $schema.$table");
466 foreach my $trigger ( sort keys %{ $triggers } ) {
467 $callback->($schema,$table,$trigger,undef) if $callback;
472 sub handle_routines {
473 my ($schema,$callback) = (shift,shift);
474 if ($schema eq 'evergreen') {
475 return; # TODO: Being the first schema in the search path, evergreen
476 # gets too polluted with non-EG stuff. Should maybe
477 # hand-add evergreen routines once we get going with pgTAP
479 my $routines = fetch_routines($schema);
480 if (!%{ $routines }) {
484 print "\n-- -- routines in schema " . $dbh->quote($schema) . "\n";
485 print "SELECT functions_are(\n";
486 print "\t" . $dbh->quote($schema) . ",\n";
487 print "\tARRAY[\n\t\t";
490 map { $dbh->quote($_) } sort keys %{ $routines }
492 print "\n\t],\t" . $dbh->quote("Found expected stored procedures for $schema");
495 foreach my $routine ( sort keys %{ $routines } ) {
497 print "\n-- -- routine " . $dbh->quote("$schema.$routine") . "\n";
499 my $parameters = fetch_parameters(
501 $routines->{$routine}->{specific_name}
503 my @params_array = (); # for trusted order and convenience
504 if (%{ $parameters }) {
505 foreach my $ord ( sort keys %{ $parameters } ) {
506 $params_array[$ord-1] = $parameters->{$ord}
510 my $troublesome_parameter = 0;
511 my $args_sig = 'ARRAY[]::TEXT[]';
512 if (scalar(@params_array) > 0) {
513 $args_sig = 'ARRAY[';
514 for (my $i = 0; $i < scalar(@params_array); $i++) {
515 $args_sig .= ($i ? ',' : '') . $dbh->quote( $params_array[$i]->{data_type} );
516 if ( $params_array[$i]->{data_type} eq 'ARRAY' ) {
517 $troublesome_parameter = 1;
519 if ( $params_array[$i]->{data_type} eq 'USER-DEFINED' ) {
520 $troublesome_parameter = 1;
525 if ($troublesome_parameter) {
526 $args_sig = ''; # this is optional in the assertion functions
527 # but not sure how it handles similarly named
528 # routines with different parameter signatures
531 print "SELECT function_lang_is(\n";
532 print "\t" . $dbh->quote($schema) . ",\n";
533 print "\t" . $dbh->quote($routine) . ",\n";
534 print "\t$args_sig,\n" if $args_sig;
535 print "\t" . $dbh->quote(lc($routines->{$routine}->{external_language})) . ",\n";
536 print "\t" . $dbh->quote("$schema.$routine written in $routines->{$routine}->{external_language}") . "\n";
540 my $data_type = $routines->{$routine}->{data_type};
541 # The following datatype munging is voodoo/heuristic to just work with
542 # the current schema. No promises that it'll always work, but the point
543 # of this script is just to create an initial set of tests; we may never
544 # use it again afterward, though I could see it being useful for seeding
545 # tests against whole new schemas/tables as they appear.
546 if ($data_type eq 'USER-DEFINED') {
547 $data_type = $routines->{$routine}->{type_udt_schema} . "."
548 . $routines->{$routine}->{type_udt_name};
549 if ($data_type eq 'public.hstore') {
550 $data_type = 'hstore'; # an exception
553 if ($data_type eq 'ARRAY') {
554 if ($routines->{$routine}->{type_udt_name} eq '_int4') {
555 $data_type = 'integer[]';
556 } elsif ($routines->{$routine}->{type_udt_name} eq '_text') {
557 $data_type = 'text[]';
559 $data_type = $routines->{$routine}->{type_udt_name} . '[]';
562 my @extra_data = fetch_pg_routines(
564 scalar(@params_array),
565 $routines->{$routine}->{routine_definition}
568 if (scalar(@extra_data) == 1) {
569 $expect_set = $extra_data[0]->{proretset};
571 $data_type = "setof $data_type" if $expect_set && $data_type ne 'void';
573 print "SELECT function_returns(\n";
574 print "\t" . $dbh->quote($schema) . ",\n";
575 print "\t" . $dbh->quote($routine) . ",\n";
576 print "\t$args_sig,\n" if $args_sig;
577 print "\t" . $dbh->quote($data_type) . ",\n";
578 print "\t" . $dbh->quote("$schema.$routine returns $data_type") . "\n";
581 for (my $i = 0; $i < scalar(@params_array); $i++) {
582 print '-- -- -- param ' . $dbh->quote( $params_array[$i]->{parameter_name} ) . "\n";
585 $callback->($schema,$routine,undef) if $callback;