#!/usr/bin/perl -- # -*- Perl -*-w
# $Id$
# Project exists to assist PostgreSQL users with their structural upgrade
# from 7.2 (or prior) to 7.3 (possibly later). Must be run against a 7.3
# database system (dump, upgrade daemon, restore, run this script)
#
# - Replace old style Foreign Keys with new style
# - Replace old SERIAL columns with new ones
# - Replace old style Unique Indexes with new style Unique Constraints
# License
# -------
# Copyright (c) 2001, Rod Taylor
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# 1. Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
#
# 2. Redistributions in binary form must reproduce the above
# copyright notice, this list of conditions and the following
# disclaimer in the documentation and/or other materials provided
# with the distribution.
#
# 3. Neither the name of the InQuent Technologies Inc. nor the names
# of its contributors may be used to endorse or promote products
# derived from this software without specific prior written
# permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
# ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
# A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE FREEBSD
# PROJECT OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
# SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
# LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
# OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
use DBI;
use strict;
# Fetch the connection information from the local environment
my $dbuser = $ENV{'PGUSER'};
$dbuser ||= $ENV{'USER'};
my $database = $ENV{'PGDATABASE'};
$database ||= $dbuser;
my $dbisset = 0;
my $dbhost = $ENV{'PGHOST'};
$dbhost ||= "";
my $dbport = $ENV{'PGPORT'};
$dbport ||= "";
my $dbpass = "";
# Yes to all?
my $yes = 0;
# Whats the name of the binary?
my $basename = $0;
$basename =~ s|.*/([^/]+)$|$1|;
## Process user supplied arguments.
for( my $i=0; $i <= $#ARGV; $i++ ) {
ARGPARSE: for ( $ARGV[$i] ) {
/^-d$/ && do { $database = $ARGV[++$i];
$dbisset = 1;
last;
};
/^-[uU]$/ && do { $dbuser = $ARGV[++$i];
if (! $dbisset) {
$database = $dbuser;
}
last;
};
/^-h$/ && do { $dbhost = $ARGV[++$i]; last; };
/^-p$/ && do { $dbport = $ARGV[++$i]; last; };
/^--password=/ && do { $dbpass = $ARGV[$i];
$dbpass =~ s/^--password=//g;
last;
};
/^-Y$/ && do { $yes = 1; last; };
/^-\?$/ && do { usage(); last; };
/^--help$/ && do { usage(); last; };
}
}
# If no arguments were set, then tell them about usage
if ($#ARGV <= 0) {
print <<MSG
No arguments set. Use '$basename --help' for help
Connecting to database '$database' as user '$dbuser'
MSG
;
}
my $dsn = "dbi:Pg:dbname=$database";
$dsn .= ";host=$dbhost" if ( "$dbhost" ne "" );
$dsn .= ";port=$dbport" if ( "$dbport" ne "" );
# Database Connection
# -------------------
my $dbh = DBI->connect($dsn, $dbuser, $dbpass);
# We want to control commits
$dbh->{'AutoCommit'} = 0;
END {
$dbh->disconnect() if $dbh;
}
findUniqueConstraints();
findSerials();
findForeignKeys();
# Find old style Foreign Keys based on:
#
# - Group of 3 triggers of the appropriate types
# -
sub findForeignKeys
{
my $sql = qq{
SELECT tgargs
, tgnargs
FROM pg_trigger
WHERE NOT EXISTS (SELECT *
FROM pg_depend
JOIN pg_constraint as c ON (refobjid = c.oid)
WHERE objid = pg_trigger.oid
AND deptype = 'i'
AND contype = 'f'
)
GROUP BY tgargs
, tgnargs
HAVING count(*) = 3;
};
my $sth = $dbh->prepare($sql);
$sth->execute() || triggerError($!);
while (my $row = $sth->fetchrow_hashref)
{
# Fetch vars
my $fkeynargs = $row->{'tgnargs'};
my $fkeyargs = $row->{'tgargs'};
my $matchtype = "MATCH SIMPLE";
my $updatetype = "";
my $deletetype = "";
if ($fkeynargs % 2 == 0 && $fkeynargs >= 6) {
my ( $keyname
, $table
, $ftable
, $unspecified
, $lcolumn_name
, $fcolumn_name
, @junk
) = split(/\000/, $fkeyargs);
# Account for old versions which don't seem to handle NULL
# but instead return a string. Newer DBI::Pg drivers
# don't have this problem
if (!defined($ftable)) {
( $keyname
, $table
, $ftable
, $unspecified
, $lcolumn_name
, $fcolumn_name
, @junk
) = split(/\\000/, $fkeyargs);
}
else
{
# Clean up the string for further manipulation. DBD doesn't deal well with
# strings with NULLs in them
$fkeyargs =~ s|\000|\\000|g;
}
# Catch and record MATCH FULL
if ($unspecified eq "FULL")
{
$matchtype = "MATCH FULL";
}
# Start off our column lists
my $key_cols = "$lcolumn_name";
my $ref_cols = "$fcolumn_name";
# Perhaps there is more than a single column
while ($lcolumn_name = shift(@junk) and $fcolumn_name = shift(@junk)) {
$key_cols .= ", $lcolumn_name";
$ref_cols .= ", $fcolumn_name";
}
my $trigsql = qq{
SELECT tgname
, relname
, proname
FROM pg_trigger
JOIN pg_proc ON (pg_proc.oid = tgfoid)
JOIN pg_class ON (pg_class.oid = tgrelid)
WHERE tgargs = ?;
};
my $tgsth = $dbh->prepare($trigsql);
$tgsth->execute($fkeyargs) || triggerError($!);
my $triglist = "";
while (my $tgrow = $tgsth->fetchrow_hashref)
{
my $trigname = $tgrow->{'tgname'};
my $tablename = $tgrow->{'relname'};
my $fname = $tgrow->{'proname'};
for ($fname)
{
/^RI_FKey_cascade_del$/ && do {$deletetype = "ON DELETE CASCADE"; last;};
/^RI_FKey_cascade_upd$/ && do {$updatetype = "ON UPDATE CASCADE"; last;};
/^RI_FKey_restrict_del$/ && do {$deletetype = "ON DELETE RESTRICT"; last;};
/^RI_FKey_restrict_upd$/ && do {$updatetype = "ON UPDATE RESTRICT"; last;};
/^RI_FKey_setnull_del$/ && do {$deletetype = "ON DELETE SET NULL"; last;};
/^RI_FKey_setnull_upd$/ && do {$updatetype = "ON UPDATE SET NULL"; last;};
/^RI_FKey_setdefault_del$/ && do {$deletetype = "ON DELETE SET DEFAULT"; last;};
/^RI_FKey_setdefault_upd$/ && do {$updatetype = "ON UPDATE SET DEFAULT"; last;};
/^RI_FKey_noaction_del$/ && do {$deletetype = "ON DELETE NO ACTION"; last;};
/^RI_FKey_noaction_upd$/ && do {$updatetype = "ON UPDATE NO ACTION"; last;};
}
$triglist .= " DROP TRIGGER \"$trigname\" ON $tablename;\n";
}
my $constraint = "";
if ($keyname ne "<unnamed>")
{
$constraint = "CONSTRAINT \"$keyname\"";
}
my $fkey = qq{
$triglist
ALTER TABLE $table ADD $constraint FOREIGN KEY ($key_cols)
REFERENCES $ftable($ref_cols) $matchtype $updatetype $deletetype;
};
# Does the user want to upgrade this sequence?
print <<MSG
The below commands will upgrade the foreign key style. Shall I execute them?
$fkey
MSG
;
if (userConfirm())
{
my $sthfkey = $dbh->prepare($fkey);
$sthfkey->execute() || $dbh->rollback();
$dbh->commit() || $dbh->rollback();
}
}
}
}
# Find possible old style Serial columns based on:
#
# - Process unique constraints. Unique indexes without
# the corresponding entry in pg_constraint)
sub findUniqueConstraints
{
my $sql = qq{
SELECT ci.relname AS index_name
, ct.relname AS table_name
, pg_catalog.pg_get_indexdef(indexrelid) AS constraint_definition
FROM pg_class AS ci
JOIN pg_index ON (ci.oid = indexrelid)
JOIN pg_class AS ct ON (ct.oid = indrelid)
JOIN pg_catalog.pg_namespace ON (ct.relnamespace = pg_namespace.oid)
WHERE indisunique
AND NOT EXISTS (SELECT TRUE
FROM pg_catalog.pg_depend
JOIN pg_catalog.pg_constraint ON (refobjid = pg_constraint.oid)
WHERE objid = indexrelid
AND objsubid = 0)
AND nspname NOT IN ('pg_catalog', 'pg_toast');
};
my $sth = $dbh->prepare($sql) || triggerError($!);
$sth->execute();
while (my $row = $sth->fetchrow_hashref)
{
# Fetch vars
my $constraint_name = $row->{'index_name'};
my $table = $row->{'table_name'};
my $columns = $row->{'constraint_definition'};
# Extract the columns from the index definition
$columns =~ s|.*\(([^\)]+)\).*|$1|g;
$columns =~ s|([^\s]+)[^\s]+_ops|$1|g;
my $upsql = qq{
DROP INDEX $constraint_name RESTRICT;
ALTER TABLE $table ADD CONSTRAINT $constraint_name UNIQUE ($columns);
};
# Does the user want to upgrade this sequence?
print <<MSG
Upgrade the Unique Constraint style via:
$upsql
MSG
;
if (userConfirm())
{
# Drop the old index and create a new constraint by the same name
# to replace it.
my $upsth = $dbh->prepare($upsql);
$upsth->execute() || $dbh->rollback();
$dbh->commit() || $dbh->rollback();
}
}
}
# Find possible old style Serial columns based on:
#
# - Column is int or bigint
# - Column has a nextval() default
# - The sequence name includes the tablename, column name, and ends in _seq
# or includes the tablename and is 40 or more characters in length.
sub findSerials
{
my $sql = qq{
SELECT nspname
, relname
, attname
, adsrc
FROM pg_catalog.pg_class as c
JOIN pg_catalog.pg_attribute as a
ON (c.oid = a.attrelid)
JOIN pg_catalog.pg_attrdef as ad
ON (a.attrelid = ad.adrelid
AND a.attnum = ad.adnum)
JOIN pg_catalog.pg_type as t
ON (t.typname IN ('int4', 'int8')
AND t.oid = a.atttypid)
JOIN pg_catalog.pg_namespace as n
ON (c.relnamespace = n.oid)
WHERE n.nspname = 'public'
AND adsrc LIKE 'nextval%'
AND adsrc LIKE '%'|| relname ||'_'|| attname ||'_seq%'
AND NOT EXISTS (SELECT *
FROM pg_catalog.pg_depend as sd
JOIN pg_catalog.pg_class as sc
ON (sc.oid = sd.objid)
WHERE sd.refobjid = a.attrelid
AND sd.refobjsubid = a.attnum
AND sd.objsubid = 0
AND deptype = 'i'
AND sc.relkind = 'S'
AND sc.relname = c.relname ||'_'|| a.attname || '_seq'
);
};
my $sth = $dbh->prepare($sql) || triggerError($!);
$sth->execute();
while (my $row = $sth->fetchrow_hashref)
{
# Fetch vars
my $table = $row->{'relname'};
my $column = $row->{'attname'};
my $seq = $row->{'adsrc'};
# Extract the sequence name from the default
$seq =~ s|^nextval\(["']+([^'"\)]+)["']+.*\)$|$1|g;
# Does the user want to upgrade this sequence?
print <<MSG
Do you wish to upgrade Sequence '$seq' to SERIAL?
Found on column $table.$column
MSG
;
if (userConfirm())
{
# Add the pg_depend entry for the serial column. Should be enough
# to fool pg_dump into recreating it properly next time. The default
# is still slightly different than a fresh serial, but close enough.
my $upsql = qq{
INSERT INTO pg_catalog.pg_depend
( classid
, objid
, objsubid
, refclassid
, refobjid
, refobjsubid
, deptype
) VALUES ( (SELECT c.oid -- classid
FROM pg_class as c
JOIN pg_namespace as n
ON (n.oid = c.relnamespace)
WHERE n.nspname = 'pg_catalog'
AND c.relname = 'pg_class')
, (SELECT c.oid -- objid
FROM pg_class as c
JOIN pg_namespace as n
ON (n.oid = c.relnamespace)
WHERE n.nspname = 'public'
AND c.relname = '$seq')
, 0 -- objsubid
, (SELECT c.oid -- refclassid
FROM pg_class as c
JOIN pg_namespace as n
ON (n.oid = c.relnamespace)
WHERE n.nspname = 'pg_catalog'
AND c.relname = 'pg_class')
, (SELECT c.oid -- refobjid
FROM pg_class as c
JOIN pg_namespace as n
ON (n.oid = c.relnamespace)
WHERE n.nspname = 'public'
AND c.relname = '$table')
, (SELECT a.attnum -- refobjsubid
FROM pg_class as c
JOIN pg_namespace as n
ON (n.oid = c.relnamespace)
JOIN pg_attribute as a
ON (a.attrelid = c.oid)
WHERE n.nspname = 'public'
AND c.relname = '$table'
AND a.attname = '$column')
, 'i' -- deptype
);
};
my $upsth = $dbh->prepare($upsql);
$upsth->execute() || $dbh->rollback();
$dbh->commit() || $dbh->rollback();
}
}
}
#######
# userConfirm
# Wait for a key press
sub userConfirm
{
my $ret = 0;
my $key = "";
# Sleep for key unless -Y was used
if ($yes == 1)
{
$ret = 1;
$key = 'Y';
}
# Wait for a keypress
while ($key eq "")
{
print "\n << 'Y'es or 'N'o >> : ";
$key = <STDIN>;
chomp $key;
# If it's not a Y or N, then ask again
$key =~ s/[^YyNn]//g;
}
if ($key =~ /[Yy]/)
{
$ret = 1;
}
return $ret;
}
#######
# triggerError
# Exit nicely, but print a message as we go about an error
sub triggerError
{
my $msg = shift;
# Set a default message if one wasn't supplied
if (!defined($msg))
{
$msg = "Unknown error";
}
print $msg;
exit 1;
}
#######
# usage
# Script usage
sub usage
{
print <<USAGE
Usage:
$basename [options] [dbname [username]]
Options:
-d <dbname> Specify database name to connect to (default: $database)
-h <host> Specify database server host (default: localhost)
-p <port> Specify database server port (default: 5432)
-u <username> Specify database username (default: $dbuser)
--password=<pw> Specify database password (default: blank)
-Y The script normally asks whether the user wishes to apply
the conversion for each item found. This forces YES to all
questions.
USAGE
;
exit 0;
}
