#!/usr/bin/perl
#
# pgrefchk - Checks referential integrity tables in a PostgreSQL
#   database
#
# Copyright 2002 David D. Kilzer.  All rights reserved.
#
# Much SQL and ideas borrowed from, "Referential Integrity Tutorial &
# Hacking the Referential Integrity tables" by Joel Burton
# http://techdocs.postgresql.org/techdocs/hackingreferentialintegrity.php
#
# This program is licensed under the same terms as Perl itself.
#

use strict;
use warnings;

use vars qw( $dbh );    # database handle

use DBI;
use Getopt::Long;


$| = 1; # flush stdout

my $VERSION = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/);

my $HELP = <<HELP;
pgrefchk [options] database dbuser dbpass [tables, ...]
  (--help)                 this help message
  (--host=host|-h host)    PostgreSQL database host
  (--port=port|-p port)    PostgreSQL database port
  (--verbose)              make output more verbose
  (--version|-v)           display version information
HELP

my $opt_help;           # --help
my $opt_host;           # --host|-h
my $opt_port;           # --port|-p
my $opt_verbose;        # --verbose
my $opt_version;        # --version|-v

my $ret_val;

my $db_dsn;
my $db_user;
my $db_pass;
my @db_tables;


#
# Check command-line switches
#

$ret_val = GetOptions(
                'help'        => \$opt_help,
                'host|h=s'    => \$opt_host,
                'port|p=s'    => \$opt_port,
                'verbose'     => \$opt_verbose,
                'version|v'   => \$opt_version,
           );

if (   ! $ret_val
    || $opt_help
    || (scalar(@ARGV) < 3 && ! $opt_version)
   )
{
    print STDERR $HELP;
    exit (defined $opt_help ? 0 : 1);
}

if ($opt_version)
{
    print STDERR "pgrefchk v$VERSION\n";
    exit 0;
}

$db_dsn  = 'dbi:Pg:dbname=' . shift @ARGV;
$db_user = shift @ARGV;
$db_pass = shift @ARGV;

if (scalar(@ARGV) > 0)
{
    @db_tables = @ARGV;
    @ARGV = ();
}


#
# Handle various command-line arguments
#

if ($opt_host)
{
    $db_dsn .= ';host=' . $opt_host;
}

if ($opt_port)
{
    $db_dsn .= ';port=' . $opt_port;
}


#
# Connect to database
#

eval
{
    $::dbh = DBI->connect($db_dsn, $db_user, $db_pass,
        +{
            RaiseError => 1,
         },
    );
};

if ($@)
{
    die "Error connecting to database: $@";
}


#
# Grab list of tables to check
#

if (scalar(@db_tables) < 1)
{

    eval
    {
        local $::dbh->{RaiseError} = 1 if (! $::dbh->{RaiseError});

        my $i = 0;      # counter
        my $sth;        # statement handle

        $sth = $::dbh->prepare(<<SQL);
  SELECT tablename
    FROM pg_tables
   WHERE tableowner = ?
ORDER BY tablename
SQL

        $sth->bind_param(++$i, $db_user);

        $sth->execute();

        while (my $r = $sth->fetchrow_arrayref())
        {
            push(@db_tables, $r->[0]);
        }

        $sth->finish();
    };

    if ($@)
    {
        $::dbh->disconnect();
        die "Error querying list of tables from database: $@";
    }

}


# 
# Check referential integrity of each table
#

eval
{
    local $::dbh->{RaiseError} = 1 if (! $::dbh->{RaiseError});

    my $found_rfi = 0;

    my %rfi_oid;

    # Grab OIDs for built-in triggers that perform referential
    #   integrity checks
    {
        my $sth;        # statement handle

        $sth = $::dbh->prepare(<<SQL);
  SELECT proname
        ,oid
    FROM pg_proc
   WHERE proname = 'RI_FKey_check_ins'
      OR proname = 'RI_FKey_check_upd'
SQL

        $sth->execute();

        while (my $r = $sth->fetchrow_arrayref())
        {
            $rfi_oid{ $r->[0] } = $r->[1];
        }

        $sth->finish();
    }

    foreach my $tab (@db_tables)
    {
        my $i = 0;      # counter
        my $sth;        # statement handle

        # Grab OID for the table we're interested in

        $sth = $::dbh->prepare(<<SQL);
  SELECT oid
    FROM pg_class
   WHERE relname = ?
SQL

        $sth->bind_param(++$i, $tab);

        $sth->execute();

        my $tab_oid = $sth->fetchrow_arrayref()->[0];

        $sth->finish();

        # Use table OID to get foreign key constraint(s)

        $i = 0; # reset counter

        $sth = $::dbh->prepare(<<SQL);
  SELECT tgnargs
        ,tgargs
    FROM pg_trigger
   WHERE tgrelid = ?
     AND tgenabled = ?
     AND tgfoid IN (@{[ join(',', ('?') x scalar(keys %rfi_oid)) ]})
SQL

        $sth->bind_param(++$i, $tab_oid);
        $sth->bind_param(++$i, 't');
        map { $sth->bind_param(++$i, $_) } values %rfi_oid;

        $sth->execute();

        while (my $r = $sth->fetchrow_arrayref())
        {
            my $tgnargs = $r->[0];
            my @tgargs = split("\000", $r->[1]);

            my @broken_constraints = ();

            # When ($tgnargs == 6), the following is true of @tgargs:
            # 0 - Name of the foreign key (trigger) constraint
            # 1 - Name of the current table
            # 2 - Name of the foreign table
            # 3 - UNSPECIFIED (unused)
            # 4 - Name of the current table's column
            # 5 - Name of the foreign table's column

            if ($tgnargs != 6)
            {
                print STDERR
                      "*** Sorry, I don't know how to parse pg_trigger.tgargs"
                    . "    when pg_trigger.tgnargs = $tgnargs\n"
                    . "    tgargs = '", join("', '", @tgargs), "'\n";
                next;
            }

            # Query for broken foreign key constraints

            # This nifty piece of SQL came from a workaround for
            # PostgreSQL v7.0.x not being able to do LEFT JOINs
            # http://openacs.org/doc/openacs/html/oracle-to-pg-porting.html

            my $sth2 = $::dbh->prepare(<<SQL);
  SELECT @{[ $tgargs[1] ]}.@{[ $tgargs[4] ]}
    FROM @{[ $tgargs[1] ]}
   WHERE @{[ $tgargs[1] ]}.@{[ $tgargs[4] ]} IS NOT NULL
     AND 0 = (SELECT COUNT(*)
                FROM @{[ $tgargs[2] ]}
               WHERE @{[ $tgargs[2] ]}.@{[ $tgargs[5] ]}
                   = @{[ $tgargs[1] ]}.@{[ $tgargs[4] ]})
SQL

            $sth2->execute();

            while (my $r2 = $sth2->fetchrow_arrayref())
            {
                push(@broken_constraints, $r2->[0]);
            }

            $sth2->finish();

            if (scalar(@broken_constraints) > 0)
            {
                print "*** ", $tgargs[0], ": ",
                      $tgargs[1], "(", $tgargs[4], ") references ",
                      $tgargs[2], "(", $tgargs[5], ")\n";
                print "    Broken: ", join(", ", @broken_constraints), "\n";
            }
            elsif ($opt_verbose)
            {
                print "--- ", $tgargs[0], ": ",
                      $tgargs[1], "(", $tgargs[4], ") references ",
                      $tgargs[2], "(", $tgargs[5], ")\n";
            }

        }

        $sth->finish();
    }
};

if ($@)
{
    $::dbh->disconnect();
    die "Error checking referential integrity of database: $@";
}

$::dbh->disconnect();

exit 0;