Q9.5: dbschema.pl

#!/usr/local/bin/perl -w
#
#       @(#)dbschema.pl 1.16    04/09/97
#
# dbschema.pl   A script to extract a database structure from
#               a Sybase database
#
# Written by:   Michael Peppler ([email protected])
#               Substantially rewritten by David Whitmarsh from a partial
#               System 10 implementation by Ashu Joglekar
# Last Mods:    9 April 1997
#
# Usage:        dbschema.pl -d database -o script.name -t pattern -s server -v
#                   where   database is self-explanatory (default: master)
#                           script.name is the output file (default: script.isql)
#                           pattern is the pattern of object names (in sysobjects)
#                           that we will look at (default: %), and server is
#                           the server to connect to (default, the value of $ENV{DSQUERY}).
#
#                   -v turns on a verbose switch.
#
#    Changes:   11/18/93 - bpapp - Put in interactive SA password prompt
#               11/18/93 - bpapp - Get protection information for views and
#                                  stored procedures.
#               02/22/94 - mpeppler - Merge bpapp's changes with itf version'
#               09/15/94 - mpeppler - Minor changes for use with Sybperl2
#                                     alpha1
#               13/10/95 - Ashu Joglekar - System 10 w/o RI
#               11/11/96 - David Whitmarsh -
#                               Use Sybase::DBlib
#                               System 10 declarative RI
#                               constraints
#                               Eliminate key truncation problems
#                               Optional password command line
#                               Debugged and strictified
#                               Some index/key options
#               17/2/97 - Michael Peppler
#                               Fixed small ',' problem in printKeys()
#               11/3/97 - David Whitmarsh
#                               bug handling user defined types used as
#                               identity columns.
#                               addtype now has scale, prec
#                               removed spurious addtypes for nchar etc.
#                               null/not null/identity on types
#               12/3/97 - Michael Peppler
#                               Added -i switch to set an alternate interfaces
#                               file.
#
#               If anyone knows a way to distinguish between key and reference
#               declarations made at column and table level, let me know.
#------------------------------------------------------------------------------


use strict;
use Sybase::DBlib;
use Getopt::Std;

require 'ctime.pl';

sub getPerms;
sub getObj;
sub printKeys;
sub getComment;
sub PrintCols;
sub DumpTable;

my ($dbproc, @dat, $dat, $udflt, $urule, %udflt, %urule, %tables, @tabnames, @col);
my ($rule, $dflt, $date, $name);

select (STDOUT); $| = 1;                # make unbuffered

getopts ('u:p:d:t:o:s:i:v');

$Getopt::Std::opt_u = `whoami` unless $Getopt::Std::opt_u;
$Getopt::Std::opt_d = 'master' unless $Getopt::Std::opt_d;
$Getopt::Std::opt_o = 'script.isql' unless $Getopt::Std::opt_o;
$Getopt::Std::opt_t = '%' unless $Getopt::Std::opt_t;
$Getopt::Std::opt_s = $ENV{DSQUERY} unless $Getopt::Std::opt_s;

open(SCRIPT, "> $Getopt::Std::opt_o") || die "Can't open $Getopt::Std::opt_o: $!\n";
open(LOG, "> $Getopt::Std::opt_o.log") || die "Can't open $Getopt::Std::opt_o.log: $!\n";

#
# Log us in to Sybase as '$Getopt::Std::opt_u' and prompt for password.
#
if (!$Getopt::Std::opt_p) {
    print "\nPassword: ";
    system("stty -echo");
    chop($Getopt::Std::opt_p = <>);
    system("stty echo");
}
if($Getopt::Std::opt_i) {
    dbsetifile($Getopt::Std::opt_i);
}

$dbproc = new Sybase::DBlib ("$Getopt::Std::opt_u", $Getopt::Std::opt_p, $Getopt::Std::opt_s);
$dbproc->dbuse ($Getopt::Std::opt_d);

#
# Just in case you compiled with dbNullIsUndef defaulting to FALSE
# (Are you reading this, Ashu?)
#
$dbproc->{"dbNullIsUndef"} = TRUE;

$date = scalar(localtime);

print "dbschema.pl on Database $Getopt::Std::opt_d\n";

print LOG "Error log from dbschema.pl on Database $Getopt::Std::opt_d on $date\n\n";
print LOG "The following objects cannot be reliably created from the script in $Getopt::Std::opt_o.
Please correct the script to remove any inconsistencies.\n\n";

print SCRIPT
    "/* This Isql script was generated by dbschema.pl on $date.  */\n";

print SCRIPT "\nuse $Getopt::Std::opt_d\ngo\n"; # Change to the appropriate database


# first, Add the appropriate user data types:
#

print "Add user-defined data types...";
print SCRIPT
    "/* Add user-defined data types: */\n\n";

$dbproc->dbcmd (< 100 and st.usertype < 100
and st.name not in  ('intn', 'nvarchar', 'sysname', 'nchar')
SQLEND
);



$dbproc->dbsqlexec;
$dbproc->dbresults;


while((@dat = $dbproc->dbnextrow))
{
    print SCRIPT "sp_addtype $dat[1], ";
    ($dat[2] =~ /char|binary/ and
        print SCRIPT "'$dat[2]($dat[0])'")
    or ($dat[2] =~ /numeric|decimal/ and
        print SCRIPT "'$dat[2]($dat[5],$dat[6])'")
    or print SCRIPT "$dat[2]";

    (($dat[8] == 1) and print SCRIPT ", 'identity'")
    or (($dat[7] == 1) and print SCRIPT ", 'null'")
    or print SCRIPT ", 'not null'";

    print SCRIPT "\ngo\n";

    # Now remember the default & rule for later.

    $urule{$dat[1]} = $dat[4] if defined($dat[4]);
    $udflt{$dat[1]} = $dat[3] if defined($dat[3]);
}

print "Done\n";

print "Create rules...";
print SCRIPT
    "\n/* Now we add the rules... */\n\n";

getObj('Rule', 'R');
print "Done\n";

print "Create defaults...";
print SCRIPT
    "\n/* Now we add the defaults... */\n\n";

getObj('Default', 'D');
print "Done\n";

print "Bind rules & defaults to user data types...";
print SCRIPT "/* Bind rules & defaults to user data types... */\n\n";

while(($dat, $dflt)=each(%udflt))
{
    print SCRIPT "sp_bindefault $dflt, $dat\ngo\n";
}
while(($dat, $rule) = each(%urule))
{
    print SCRIPT "sp_bindrule $rule, $dat\ngo\n";
}
print "Done\n";

print "Create Tables & Indices...";
print "\n" if $Getopt::Std::opt_v;

# the fourth column set to 'N' becomes the indicator that this table has been 
# printed

$dbproc->dbcmd (<dbsqlexec;
$dbproc->dbresults;

while((@dat = $dbproc->dbnextrow))
{
    $tables{@dat[1] . "." . @dat[0]} = [ @dat ];
    @tabnames = ( @tabnames, @dat[1] . "." . @dat[0] );
}


foreach $name (@tabnames) {
    DumpTable ($tables{$name}, ());
}

print "Done\n";

#
# The key definitions - sp_primarykey etc, not constraints
# Primary keys first, then foreign and common
#

printKeys ();

#
# Now create any views that might exist
#

print "Create views...";
print SCRIPT
    "\n/* Now we add the views... */\n\n";

getObj('View', 'V');

print "Done\n";

#
# Now create any stored procs that might exist
#

print "Create stored procs...";
print SCRIPT
    "\n/* Now we add the stored procedures... */\n\n";
getObj('Stored Proc', 'P');

print "Done\n";

#
# Now create the triggers
#

print "Create triggers...";
print SCRIPT
    "\n/* Now we add the triggers... */\n\n";

getObj('Trigger', 'TR');


print "Done\n";

print "\nLooks like I'm all done!\n";
close(SCRIPT);
close(LOG);

dbexit;


sub getPerms
{
    my ($obj) = $_[0];
    my ($ret, @dat, $act, $cnt);

    $dbproc->dbcmd ("sp_helprotect '$obj'\n");
    $dbproc->dbsqlexec;

    $cnt = 0;
    while(($ret = $dbproc->dbresults) != NO_MORE_RESULTS && $ret != FAIL)
    {
        while(@dat = $dbproc->dbnextrow)
        {
            $act = 'to';
            $act = 'from' if $dat[0] =~ /Revoke/;
            print SCRIPT "$dat[2] $dat[3] on $obj $act $dat[1]\n";
            ++$cnt;
        }
    }
    $cnt;
}

sub getObj
{
    my ($objname, $obj) = @_;
    my (@dat, @items, @vi, $found, $text);
    
    $dbproc->dbcmd (<dbsqlexec;
    $dbproc->dbresults;

    while((@dat = $dbproc->dbnextrow))
    {
        push (@items, [ @dat ]);        # and save it in a list
    }

    foreach (@items)
    {
        @vi = @$_;
        $found = 0;

        $dbproc->dbcmd ("select text from dbo.syscomments where id = $vi[2]");
        $dbproc->dbsqlexec;
        $dbproc->dbresults;
        
        print SCRIPT
            "/* $objname $vi[0], owner $vi[1] */\n";

        while(($text) = $dbproc->dbnextrow)
        {
            if(!$found && $vi[1] ne 'dbo')
            {
                ++$found if($text =~ /$vi[1]/);
            }
            print SCRIPT $text;
        }
        print SCRIPT "\ngo\n";
        if(!$found && $vi[1] ne 'dbo')
        {
            print "**Warning**\n$objname $vi[0] has owner $vi[1]\nbut this is not mentioned in the CREATE PROC statement!!\n";
            print LOG "$objname $vi[0] (owner $vi[1])\n";
        }
        if ($obj eq 'V' || $obj eq 'P')
        {
           getPerms("$vi[0]") && print SCRIPT "go\n";
        }

    }
}

sub printKeys
{

print "Create sp_*key definitions...";
print SCRIPT "\n/* Now create the key definitions ...*/\n\n";

$dbproc->dbcmd (<dbsqlexec;
$dbproc->dbresults;


while((@dat = $dbproc->dbnextrow)) {

    if ($dat[0] eq "primary") {
        print SCRIPT "sp_primarykey $dat[1],";

        PrintCols (@dat[3..10]);

        print SCRIPT "\ngo\n";
    }
    if ($dat[0] eq "foreign") {
        print SCRIPT "sp_foreignkey $dat[1], $dat[2],";

        PrintCols (@dat[11..18]);

        print SCRIPT "\ngo\n";
    }
    if ($dat[0] eq "common") {
        print SCRIPT "sp_commonkey $dat[1], $dat[2],";

        PrintCols (@dat[3..10]);

        print SCRIPT "\ngo\n";
    }
}

print "done\n"
        

}

sub getComment
{

    my ($objid) = @_;
    my ($line, $text);

    $dbproc->dbcmd (
        qq(select text from dbo.syscomments where id = $objid)); 
    $dbproc->dbsqlexec;
    $dbproc->dbresults;
    
    $text = "";

    while(($line) = $dbproc->dbnextrow)
    {
        $text = $text . $line;
    }

    return $text;
}

sub PrintCols
{
    my ($col, $first);

    $first = 1;
    while ($col = shift (@_)) {
        last if ($col eq '*');
        print SCRIPT ", " if !$first;
        $first = 0;
        print SCRIPT "$col";
    }
}

# Note: this is a recursive subroutine.
# If the current table references another that is in the list of
# tables to be dumped, and if that table has not yet been dumped,
# then DumpTable is called to dump it before proceeding

sub DumpTable
{

    my ($tabref, @referers) = @_;

    return if @$tabref[3] eq "Y";

    my @nul = ('not null','null');
    my (@dat, $dat, @col);
    my (@refcols, @reflist, @field, $rule, $dflt, %rule, %dflt, $ddlrule, $ddldflt);
    my ($refname, $first, $matchstring, $field, @constrids, $constrid);
    my ($frgntabref);
    my ($nultype);

# first, get any reference and ensure that dependent tables have already been
# created

    $dbproc->dbcmd (<dbsqlexec;
    $dbproc->dbresults;

    while((@refcols = $dbproc->dbnextrow))
    {
        push (@reflist, [ @refcols ]);
    }

    foreach (@reflist) {

        @refcols = @$_;

# if the foreign table is in a foreign database or is not in 
# our table list, then don't do any more than add it to the list

        next if $refcols[0] ne $Getopt::Std::opt_d;

        $refname = $refcols[3] . "." . $refcols[2];

        next if not defined ($tables{$refname});

        $frgntabref = $tables{$refname};

# otherwise check if it's already been dumped, if so, continue

        next if @$frgntabref[3] eq "Y";

# make sure we aren't in a refernce loop by checking to see if this table is
# already in the heirarchy of refering tables that led to the current invocation

        grep ($refname, @referers)
            && print SCRIPT "/* WARNING: circular foreign key reference to $refname */\n"
            && print LOG "@$tabref[1].@$tabref[0] in circular foreign key reference to $refname\n";

# so dump the referenced tables first

        DumpTable ($frgntabref, @referers, $refname);
    }

    print "Creating table @$tabref[0], owner @$tabref[1]\n" if $Getopt::Std::opt_v;

    print SCRIPT "/* Start of description of table @$tabref[1].@$tabref[0] */\n\n";

$dbproc->dbcmd (<dbsqlexec;
    $dbproc->dbresults;

    undef(%rule);
    undef(%dflt);

    print SCRIPT "\n\nCREATE TABLE @$tabref[1].@$tabref[0] (\n"; 
    $first = 1;
    @col = ();
    while (@field = $dbproc->dbnextrow)
    {
        push @col, [ @field ];
    }

    foreach (@col) {
        @field = @$_;

        print SCRIPT ",\n" if !$first;          # add a , and a \n if not first field in table

        # get the declarative rule and default (if set)

        if ($field[9] != 0) {
            $ddldflt = getComment ($field[11]);
        } else {
            $ddldflt = "";
        }
        if ($field[10] != 0) {
            $ddlrule = getComment ($field[12]);
        } else {
            $ddlrule = "";
        }
        
        # Check if its an identity column
        if ($field[8] == 1) {   
            $nultype = "identity";
        } else {
            $nultype = $nul[$field[5]];
        }

        print SCRIPT "\t$field[0] \t$field[1]";
        print SCRIPT "($field[2])" if $field[1] =~ /char|bin/;
        print SCRIPT "($field[3],$field[4])" if $field[1] =~ /numeric|decimal/;
        print SCRIPT " $ddldflt $nultype $ddlrule";

        if (defined ($field[7])
            && ((!defined ($urule{$field[1]})) || $urule{$field[1]} ne $field[7])
            && ($field[10] == 0)) {
            $rule{"@$tabref[0].$field[0]"} = $field[7];
        }

        if (defined ($field[6])
            && ((!defined ($udflt{$field[1]})) || $udflt{$field[1]} ne $field[6])
            && ($field[9] == 0)) {
            $dflt{"@$tabref[0].$field[0]"} = $field[6];
        }
        $first = 0 if $first;
        
    }

# references

    foreach (@reflist) {
        @refcols = @$_;

        print SCRIPT ",";

        $refname = $refcols[3] . "." . $refcols[2];

        if ($refcols[0] ne $Getopt::Std::opt_d) {
            print SCRIPT "\n/* The following reference is in database
** $refcols[0], edit the script to create the reference manually
";
            print LOG "Reference for @$tabref[1].@$tabref[0] in foreign database\n\t";
            $refname = $refcols[0] . "." . $refname;
        }
        print SCRIPT "\n\t";

        $matchstring = substr($refcols[1], 0, 8) . "[_0-9][_0-9]*";
        $refcols[1] !~ /$matchstring/
                && print SCRIPT "CONSTRAINT $refcols[1] ";

        print SCRIPT "FOREIGN KEY (";
        
        PrintCols (@refcols[4..19]);

        print SCRIPT ") REFERENCES $refname (";

        PrintCols (@refcols[20..35]);
        
        print SCRIPT ")";

        if ($refcols[0] ne $Getopt::Std::opt_d) {
            print SCRIPT "*/";
        }
    }

# now get the indexes and keys...
#

    print "Indexes for table @$tabref[1].@$tabref[0]\n" if $Getopt::Std::opt_v;
    
    $dbproc->dbcmd (<dbsqlexec;
    $dbproc->dbresults;

    @col = ();

    while((@field = $dbproc->dbnextrow))
    {
# if this is a key or unique constraint, print out the details
# otherwise buffer it up to print as an index afterwards

        if ($field[3] & 2) {
            print (SCRIPT ",\n\t");
            print SCRIPT "CONSTRAINT $field[0] " unless ($field[3] & 8);

            if ($field[2] & 2048) {
                print SCRIPT "PRIMARY KEY ";
                print SCRIPT "NONCLUSTERED " if ($field[1] != 1);
            } else {
                print SCRIPT "UNIQUE ";
                print SCRIPT "CLUSTERED " if ($field[1] == 1);
            }
            print SCRIPT "(";
            PrintCols (@field[4..19]);
            print SCRIPT ")";
        } else {
            push @col, [ @field ];
        }
    }

# Now do the table level check constraints

    @constrids = ();

    $dbproc->dbcmd (<dbsqlexec;
    $dbproc->dbresults;

    while (@field = $dbproc->dbnextrow) {
        @constrids = (@constrids, $field[0]);
    }

    foreach $constrid (@constrids) {
        print SCRIPT ",\n\t" . getComment ($constrid);
    }

    print SCRIPT "\n)\ngo\n";   # end of CREATE TABLE

    foreach (@col) {    # now print the indexes

        @field = @$_;

        print SCRIPT "\nCREATE ";
        print SCRIPT "UNIQUE " if $field[2] & 2;
        print SCRIPT "CLUSTERED " if $field[1] == 1;
        print SCRIPT "INDEX $field[0]\n";
        print SCRIPT "ON @$tabref[1].@$tabref[0] (";

        PrintCols (@field[4..19]);
        
        print SCRIPT ")";

        $first = 1;
        if ($field[2] & 64) {
            print SCRIPT " WITH ALLOW_DUP_ROW";
            $first = 0;
        }
        if ($field[2] & 1) {
            print SCRIPT (($first == 0) ? ", " : " WITH ") . "IGNORE_DUP_KEY";
            $first = 0;
        }
        if ($field[2] & 4) {
            print SCRIPT (($first == 0) ? ", " : " WITH ") . "IGNORE_DUP_ROW";
            $first = 0;
        }

        print SCRIPT "\ngo\n";

    }

    getPerms("@$tabref[1].@$tabref[0]") && print SCRIPT "go\n";

    print "Bind rules & defaults to columns...\n" if $Getopt::Std::opt_v;
    print SCRIPT "/* Bind rules & defaults to columns... */\n\n";

    if(@$tabref[1] ne 'dbo' && (keys(%dflt) || keys(%rule)))
    {
        print SCRIPT "/* The owner of the table is @$tabref[1].
 * I can't bind the rules/defaults to a table of which I am not the owner.
 * The procedures below will have to be run manualy by user @$tabref[1].
 */";
        print LOG "Defaults/Rules for @$tabref[1].@$tabref[0] could not be bound\n";
    }

    while(($dat, $dflt)=each(%dflt))
    {
        print SCRIPT "/* " if @$tabref[1] ne 'dbo';
        print SCRIPT "sp_bindefault $dflt, '$dat'";
        if(@$tabref[1] ne 'dbo')
        {
            print SCRIPT " */\n";
        }
        else
        {
            print SCRIPT "\ngo\n";
        }
    }
    while(($dat, $rule) = each(%rule))
    {
        print SCRIPT "/* " if @$tabref[1] ne 'dbo';
        print SCRIPT "sp_bindrule $rule, '$dat'";
        if(@$tabref[1] ne 'dbo')
        {
            print SCRIPT " */\n";
        }
        else
        {
            print SCRIPT "\ngo\n";
        }
    }
    print SCRIPT "\n/* End of description of table @$tabref[1].@$tabref[0] */\n";

    @$tabref[3] = "Y";

}