Open-ILS/src/sql/Pg/make-pgtap-tests.pl

   1 #!/usr/bin/perl
   2 # vim:et:ts=4:
   3 use strict;
   4 use warnings;
   5 use Getopt::Long;
   6
   7 my ($db_name, $db_host, $db_port, $db_user, $db_pw) =
   8     ( 'evergreen', 'localhost', '5432', 'evergreen', 'evergreen' );
   9
  10 GetOptions(
  11     'db_name=s' => \$db_name,
  12     'db_host=s' => \$db_host,
  13     'db_port=s' => \$db_port,
  14     'db_user=s' => \$db_user,
  15     'db_pw=s' => \$db_pw,
  16 );
  17
  18 #----------------------------------------------------------
  19 # Database connection
  20 #----------------------------------------------------------
  21
  22 use DBI;
  23
  24 my $dsn = "dbi:Pg:dbname=$db_name;host=$db_host;port=$db_port";
  25 my $dbh = DBI->connect($dsn, $db_user, $db_pw);
  26
  27 # Short-circuit if we didn't connect successfully
  28 unless($dbh) {
  29     warn "* Unable to connect to database $dsn, user=$db_user, password=$db_pw\n";
  30     exit 1;
  31 }
  32
  33 #----------------------------------------------------------
  34 # Main logic
  35 #----------------------------------------------------------
  36
  37 print pgtap_sql_header();
  38 handle_schemas(
  39     sub {
  40         my $schema = shift;
  41
  42         sub handle_table_things {
  43             my $schema = shift;
  44             my $table_or_view = shift;
  45             handle_columns(
  46                 $schema,
  47                 $table_or_view,
  48                 undef
  49             );
  50             handle_triggers(
  51                 $schema,
  52                 $table_or_view,
  53                 undef
  54             );
  55         }
  56
  57         handle_tables(
  58             $schema,
  59             \&handle_table_things
  60         );
  61         handle_views(
  62             $schema,
  63             \&handle_table_things
  64         );
  65
  66         handle_routines(
  67             $schema,
  68             undef
  69         );
  70     }
  71 );
  72 print pgtap_sql_footer();
  73
  74 $dbh->disconnect;
  75 exit 0;
  76
  77 #----------------------------------------------------------
  78 # subroutines
  79 #----------------------------------------------------------
  80
  81 sub pgtap_sql_header {
  82     return q^
  83 \set ECHO none
  84 \set QUIET 1
  85 -- Turn off echo and keep things quiet.
  86
  87 -- Format the output for nice TAP.
  88 \pset format unaligned
  89 \pset tuples_only true
  90 \pset pager
  91
  92 -- Revert all changes on failure.
  93 \set ON_ERROR_ROLLBACK 1
  94 \set ON_ERROR_STOP true
  95 \set QUIET 1
  96
  97 -- Load the TAP functions.
  98 BEGIN;
  99
 100 -- Plan the tests.
 101 SELECT no_plan();
 102
 103 -- Run the tests.
 104 ^;
 105 }
 106
 107 sub pgtap_sql_footer {
 108     return q^
 109 -- Finish the tests and clean up.
 110 SELECT * FROM finish();
 111 ROLLBACK;
 112 ^;
 113 }
 114
 115 sub fetch_schemas {
 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_';
 121     ");
 122     $sth->execute(($db_name));
 123     my $schemas = $sth->fetchall_arrayref([0]);
 124     $sth->finish;
 125     return sort map { $_->[0] } @{ $schemas };
 126 }
 127
 128 sub fetch_tables {
 129     my $schema = shift;
 130     my $sth = $dbh->prepare("
 131         SELECT table_name FROM information_schema.tables
 132             WHERE table_catalog = ?
 133             AND table_schema = ?
 134             AND table_type = 'BASE TABLE'
 135     ");
 136     $sth->execute(($db_name,$schema));
 137     my $tables = $sth->fetchall_arrayref([0]);
 138     $sth->finish;
 139     return sort map { $_->[0] } @{ $tables };
 140 }
 141
 142 sub fetch_views {
 143     my $schema = shift;
 144     my $sth = $dbh->prepare("
 145         SELECT table_name FROM information_schema.tables
 146             WHERE table_catalog = ?
 147             AND table_schema = ?
 148             AND table_type = 'VIEW'
 149     ");
 150     $sth->execute(($db_name,$schema));
 151     my $tables = $sth->fetchall_arrayref([0]);
 152     $sth->finish;
 153     return sort map { $_->[0] } @{ $tables };
 154 }
 155
 156 sub fetch_columns {
 157     my ($schema,$table) = (shift,shift);
 158     my $sth = $dbh->prepare("
 159         SELECT
 160             column_name,
 161             data_type,
 162             is_nullable,
 163             column_default,
 164             numeric_precision,
 165             numeric_scale,
 166             udt_schema,
 167             udt_name,
 168             character_maximum_length
 169         FROM information_schema.columns
 170             WHERE table_catalog = ?
 171             AND table_schema = ?
 172             AND table_name = ?
 173     ");
 174     $sth->execute(($db_name,$schema,$table));
 175     my $columns = $sth->fetchall_hashref('column_name');
 176     $sth->finish;
 177     return $columns;
 178 }
 179
 180 sub fetch_triggers {
 181     my ($schema,$table) = (shift,shift);
 182     my $sth = $dbh->prepare("
 183         SELECT DISTINCT
 184             trigger_schema,
 185             trigger_name,
 186             event_object_schema,
 187             event_object_table
 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
 193     ");
 194     $sth->execute(($db_name,$schema,$table));
 195     my $triggers = $sth->fetchall_hashref('trigger_name');
 196     $sth->finish;
 197     return $triggers;
 198 }
 199
 200 sub fetch_routines {
 201     my $schema = shift;
 202     my $sth = $dbh->prepare("
 203         SELECT
 204             *
 205         FROM information_schema.routines
 206             WHERE routine_catalog = ?
 207             AND routine_schema = ?
 208     ");
 209     $sth->execute(($db_name,$schema));
 210     my $routines = $sth->fetchall_hashref('routine_name');
 211     $sth->finish;
 212     return $routines;
 213 }
 214
 215 sub fetch_pg_routines { # uses pg_catalog.pg_proc instead of information_schema.routines
 216     my $name = shift;
 217     my $nargs = shift;
 218     my $src = shift;
 219     my $sth = $dbh->prepare("
 220         SELECT
 221             *
 222         FROM pg_catalog.pg_proc
 223             WHERE proname = ?
 224             AND pronargs = ?
 225             AND prosrc = ?
 226     ");
 227     $sth->execute(($name,$nargs,$src));
 228     my $routines = $sth->fetchall_hashref([ qw(proname proargtypes pronamespace) ]);
 229     $sth->finish;
 230     my @rows = ();
 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};
 235             }
 236         }
 237     }
 238
 239     return @rows;
 240 }
 241
 242 sub fetch_parameters {
 243     my $schema = shift;
 244     my $specific_routine = shift;
 245     my $sth = $dbh->prepare("
 246         SELECT
 247             *
 248         FROM information_schema.parameters
 249             WHERE specific_catalog = ?
 250             AND specific_schema = ?
 251             AND specific_name = ?
 252             AND parameter_mode = 'IN'
 253     ");
 254     $sth->execute(($db_name,$schema,$specific_routine));
 255     my $parameters = $sth->fetchall_hashref('ordinal_position');
 256     $sth->finish;
 257     return $parameters;
 258 }
 259
 260 sub handle_schemas {
 261     my $callback = shift;
 262
 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;
 270     }
 271 }
 272
 273 sub handle_tables {
 274     my $schema = shift;
 275     my $callback = shift;
 276
 277     my @tables = fetch_tables($schema);
 278     if (scalar @tables == 0) {
 279         return;
 280     }
 281
 282     print "SELECT tables_are(\n";
 283     print "\t" . $dbh->quote($schema) . ",\n";
 284     print "\tARRAY[\n\t\t";
 285     print join(
 286         ",\n\t\t",
 287         map { $dbh->quote($_) } @tables
 288     );
 289     print "\n\t],\t" . $dbh->quote("Found expected tables for schema $schema");
 290     print "\n);\n";
 291
 292     foreach my $table ( @tables ) {
 293         print "\n-- -- table " . $dbh->quote("$schema.$table") . "\n\n";
 294         $callback->($schema,$table) if $callback;
 295     }
 296 }
 297
 298 sub handle_views {
 299     my $schema = shift;
 300     my $callback = shift;
 301
 302     my @views = fetch_views($schema);
 303     if (scalar @views == 0) {
 304         return;
 305     }
 306
 307     print "SELECT views_are(\n";
 308     print "\t" . $dbh->quote($schema) . ",\n";
 309     print "\tARRAY[\n\t\t";
 310     print join(
 311         ",\n\t\t",
 312         map { $dbh->quote($_) } @views
 313     );
 314     print "\n\t],\t" . $dbh->quote("Found expected views for schema $schema");
 315     print "\n);\n";
 316
 317     foreach my $view ( @views ) {
 318         print "\n-- -- view " . $dbh->quote("$schema.$view") . "\n\n";
 319         $callback->($schema,$view) if $callback;
 320     }
 321 }
 322
 323 sub handle_columns {
 324     my ($schema,$table,$callback) = (shift,shift,shift);
 325     my $columns = fetch_columns($schema,$table);
 326     if (!%{ $columns }) {
 327         return;
 328     }
 329
 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";
 334     print join(
 335         ",\n\t\t",
 336         map { $dbh->quote($_) } sort keys %{ $columns }
 337     );
 338     print "\n\t],\t" . $dbh->quote("Found expected columns for $schema.$table");
 339     print "\n);\n";
 340
 341     foreach my $column ( sort keys %{ $columns } ) {
 342
 343         $callback->($schema,$table,$column,undef) if $callback;
 344
 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};
 354
 355         if (defined $col_default && $col_default =~ /::text/) {
 356             $col_default =~ s/^'(.*)'::text$/$1/;
 357         }
 358         if (defined $col_default && $col_default =~ /::bpchar/) {
 359             $col_default =~ s/^'(.*)'::bpchar$/$1/;
 360         }
 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";
 365             }
 366             $col_type .= ')';
 367         }
 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
 372             }
 373         }
 374         if ($col_type eq 'character' && defined $col_character_maximum_length) {
 375             $col_type .= "($col_character_maximum_length)";
 376         }
 377         if ($col_type eq 'ARRAY' && defined $col_udt_name) {
 378             $col_type = substr($col_udt_name,1) . '[]';
 379         }
 380
 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");
 388         print "\n);\n";
 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");
 395             print "\n);\n";
 396         } else {
 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");
 402             print "\n);\n";
 403         }
 404         if (defined $col_default) {
 405             my $fixme = '';
 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'
 419                 && (
 420                     $col_udt_name eq 'hstore'
 421                     || $col_udt_name eq 'authority_queue_queue_type'
 422                     || $col_udt_name eq 'bib_queue_queue_type'
 423                 )
 424             ) {
 425                 # FIXME - ERROR:  Unexpected end of string
 426                 $fixme = '-- FIXME type 5 -- ';
 427             }
 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";
 436         } else {
 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");
 442             print "\n);\n";
 443         }
 444     }
 445 }
 446
 447 sub handle_triggers {
 448     my ($schema,$table,$callback) = (shift,shift,shift);
 449     my $triggers = fetch_triggers($schema,$table);
 450     if (!%{ $triggers }) {
 451         return;
 452     }
 453
 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";
 459     print join(
 460         ",\n\t\t",
 461         map { $dbh->quote($_) } sort keys %{ $triggers }
 462     );
 463     print "\n\t],\t" . $dbh->quote("Found expected triggers for $schema.$table");
 464     print "\n);\n";
 465
 466     foreach my $trigger ( sort keys %{ $triggers } ) {
 467         $callback->($schema,$table,$trigger,undef) if $callback;
 468     }
 469
 470 }
 471
 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
 478     }
 479     my $routines = fetch_routines($schema);
 480     if (!%{ $routines }) {
 481         return;
 482     }
 483
 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";
 488     print join(
 489         ",\n\t\t",
 490         map { $dbh->quote($_) } sort keys %{ $routines }
 491     );
 492     print "\n\t],\t" . $dbh->quote("Found expected stored procedures for $schema");
 493     print "\n);\n";
 494
 495     foreach my $routine ( sort keys %{ $routines } ) {
 496
 497         print "\n-- -- routine " . $dbh->quote("$schema.$routine") . "\n";
 498
 499         my $parameters = fetch_parameters(
 500             $schema,
 501             $routines->{$routine}->{specific_name}
 502         );
 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}
 507             }
 508         }
 509
 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;
 518                 }
 519                 if ( $params_array[$i]->{data_type} eq 'USER-DEFINED' ) {
 520                     $troublesome_parameter = 1;
 521                 }
 522             }
 523             $args_sig .= ']';
 524         }
 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
 529         }
 530
 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";
 537         print ");\n";
 538
 539
 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
 551             }
 552         }
 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[]';
 558             } else {
 559                 $data_type = $routines->{$routine}->{type_udt_name} . '[]';
 560             }
 561         }
 562         my @extra_data = fetch_pg_routines(
 563             $routine,
 564             scalar(@params_array),
 565             $routines->{$routine}->{routine_definition}
 566         );
 567         my $expect_set = 0;
 568         if (scalar(@extra_data) == 1) {
 569            $expect_set = $extra_data[0]->{proretset};
 570         }
 571         $data_type = "setof $data_type" if $expect_set && $data_type ne 'void';
 572
 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";
 579         print ");\n";
 580
 581         for (my $i = 0; $i < scalar(@params_array); $i++) {
 582             print '-- -- -- param ' . $dbh->quote( $params_array[$i]->{parameter_name} ) . "\n";
 583         }
 584
 585         $callback->($schema,$routine,undef) if $callback;
 586     }
 587 }
 588
 589