Lp 1730726: Fix a number of PgTap tests for PostgreSQL 10.
[Evergreen.git] / 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