DBI test: consistent object TYPEs from table_info()

table_info_types.t

#! /usr/bin/perl

# Test whether a DBD returns sensible object TYPE listings for a given
# database.
#
#
# Usage:  perl table_info_types.t DSN [USER [PASS]]
#         -or-
#         perl table_info_types.t DBIx_CONFIG_SPEC
#         -or-
#         DBI_DSN=... DBI_USER=... DBI_PASS= perl table_info_types.t
#

use strict;
use warnings;
use DBI;

use Test::More tests => 2;

our (
      %Advertised,   # What object TYPES are said to be supported
      %Observed,     # What object TYPES we actually see
    );

# -- main

my $dbi = 'DBI';
if (@ARGV and $ARGV[0] !~ /^dbi:/i) {
  require DBIx::Config;
  $dbi = 'DBIx::Config';
}

my $dbh = $dbi->connect(@ARGV[0..2], {RaiseError => 1});
ok($dbh, "connect succeeded");

note "Connected to $dbh->{Name}";
diag("Driver: $dbh->{Driver}{Name} " .  eval { $dbh->{Driver}{Version} });

for my $args (['%', '%', '%'], [undef, '%', '%'], [undef, undef, '%']) {
	my $sth = $dbh->table_info(@$args);
	while (my $r = $sth->fetch) {
		my $type = $r->[3];
		next unless defined $type;
		$Observed{$type}++;
	}
  # We could probably stop after getting *any* results on any iteration
}

my $sth = $dbh->table_info('', '', '', '%');
while (my $r = $sth->fetch) {
	$Advertised{$r->[3]}++ if defined $r->[3];
}

# -- Observed must be a subset of Advertised

my @unexpected = sort grep { not $Advertised{$_} } keys %Observed;

diag("\nAdvertised: " . join(', ' => sort keys %Advertised));
diag(  "Observed:   " . join(', ' => sort keys %Observed));
unless (grep {/SYSTEM/} keys %Observed) {
  diag("WARNING: no SYSTEM objects observed.  Insufficient privilege?");
}

ok(@unexpected == 0, "TYPEs observed are a subset of TYPEs advertised") or
  diag("\nUnexpected: " . join(', ' => @unexpected));