#!/usr/bin/env perl
# -- # -*- Perl -*-w
-# $Header: /cvsroot/autodoc/autodoc/postgresql_autodoc.pl,v 1.7 2005/02/27 18:08:06 rbt Exp $
+# $Header: /cvsroot/autodoc/autodoc/postgresql_autodoc.pl,v 1.8 2005/02/27 19:38:12 rbt Exp $
# Imported 1.22 2002/02/08 17:09:48 into sourceforge
-# Postgres Auto-Doc Version 1.24
+# Postgres Auto-Doc Version 1.25
# License
# -------
# 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
+# 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
# About Project
# -------------
-# Various details about the project and related items can be found at
+# Various details about the project and related items can be found at
# the website
#
# http://www.rbt.ca/autodoc/
-use DBI;
use strict;
+use warnings;
+
+use DBI;
# Allows file locking
use Fcntl;
-## Useful for debugging ##
-#use Data::Dumper;
-
# Allows file templates
use HTML::Template;
-# The templates path
-# @@TEMPLATE-DIR@@ will be replaced by make in the build phase
-my $template_path = '@@TEMPLATE-DIR@@';
-
-# Setup the default connection variables based on the environment
-my $dbuser = $ENV{'PGUSER'};
-$dbuser ||= $ENV{'USER'};
-
-my $database = $ENV{'PGDATABASE'};
-$database ||= $dbuser;
-
-my $dbhost = $ENV{'PGHOST'};
-$dbhost ||= "";
-
-my $dbport = $ENV{'PGPORT'};
-$dbport ||= "";
-
-my $dbpass = "";
-my $output_filename_base = $database;
-
-# Tracking variables
-my $dbisset = 0;
-my $fileisset = 0;
-
-my $only_schema;
-
-my $wanted_output = undef; # means all types
-
-my $statistics = 0;
-
-# Fetch base and dirnames. Useful for Usage()
-my $basename = $0;
-my $dirname = $0;
-$basename =~ s|^.*/([^/]+)$|$1|;
-$dirname =~ s|^(.*)/[^/]+$|$1|;
-
-# If template_path isn't defined, lets set it ourselves
-$template_path = $dirname if (!defined($template_path));
-
-for ( my $i = 0 ; $i <= $#ARGV ; $i++ ) {
- ARGPARSE: for ( $ARGV[$i] ) {
- # Set the database
- /^-d$/ && do {
- $database = $ARGV[ ++$i ];
- $dbisset = 1;
- if ( !$fileisset ) {
- $output_filename_base = $database;
- }
- last;
- };
-
- # Set the user
- /^-[uU]$/ && do {
- $dbuser = $ARGV[ ++$i ];
- if ( !$dbisset ) {
- $database = $dbuser;
- if ( !$fileisset ) {
- $output_filename_base = $database;
- }
- }
- last;
- };
-
- # Set the hostname
- /^-h$/ && do { $dbhost = $ARGV[ ++$i ]; last; };
-
- # Set the Port
- /^-p$/ && do { $dbport = $ARGV[ ++$i ]; last; };
-
- # Set the users password
- /^--password=/ && do {
- $dbpass = $ARGV[$i];
- $dbpass =~ s/^--password=//g;
- last;
- };
-
- # Set the base of the filename. The extensions pulled from the templates
- # will be appended to this name
- /^-f$/ && do {
- $output_filename_base = $ARGV[++$i];
- $fileisset = 1;
- last;
- };
-
- # Set the template directory explicitly
- /^(-l|--library)$/ && do {
- $template_path = $ARGV[++$i];
- last;
- };
-
- # Set the output type
- /^(-t|--type)$/ && do {
- $wanted_output = $ARGV[++$i];
- last;
- };
-
- # User has requested a single schema dump and provided a pattern
- /^(-s|--schema)$/ && do {
- $only_schema = $ARGV[++$i];
- last;
- };
-
- # Check to see if Statistics have been requested
- /^--statistics$/ && do {
- $statistics = 1;
- last;
- };
-
- # Help is wanted, redirect user to usage()
- /^-\?$/ && do { usage(); last; };
- /^--help$/ && do { usage(); last; };
- }
-}
+sub main($)
+{
+ my ($ARGV) = @_;
+
+ my %db;
+
+ # The templates path
+ # @@TEMPLATE-DIR@@ will be replaced by make in the build phase
+ my $template_path = '@@TEMPLATE-DIR@@';
+
+ # Setup the default connection variables based on the environment
+ my $dbuser = $ENV{'PGUSER'};
+ $dbuser ||= $ENV{'USER'};
+
+ my $database = $ENV{'PGDATABASE'};
+ $database ||= $dbuser;
+
+ my $dbhost = $ENV{'PGHOST'};
+ $dbhost ||= "";
+
+ my $dbport = $ENV{'PGPORT'};
+ $dbport ||= "";
+
+ my $dbpass = "";
+ my $output_filename_base = $database;
+
+ # Tracking variables
+ my $dbisset = 0;
+ my $fileisset = 0;
+
+ my $only_schema;
+
+ my $wanted_output = undef; # means all types
+
+ my $statistics = 0;
+
+ # Fetch base and dirnames. Useful for Usage()
+ my $basename = $0;
+ my $dirname = $0;
+ $basename =~ s|^.*/([^/]+)$|$1|;
+ $dirname =~ s|^(.*)/[^/]+$|$1|;
+
+ # If template_path isn't defined, lets set it ourselves
+ $template_path = $dirname if ( !defined($template_path) );
+
+ for ( my $i = 0; $i <= $#ARGV; $i++ ) {
+ ARGPARSE: for ( $ARGV[$i] ) {
+
+ # Set the database
+ /^-d$/ && do {
+ $database = $ARGV[ ++$i ];
+ $dbisset = 1;
+ if ( !$fileisset ) {
+ $output_filename_base = $database;
+ }
+ last;
+ };
+
+ # Set the user
+ /^-[uU]$/ && do {
+ $dbuser = $ARGV[ ++$i ];
+ if ( !$dbisset ) {
+ $database = $dbuser;
+ if ( !$fileisset ) {
+ $output_filename_base = $database;
+ }
+ }
+ last;
+ };
+
+ # Set the hostname
+ /^-h$/ && do { $dbhost = $ARGV[ ++$i ]; last; };
+
+ # Set the Port
+ /^-p$/ && do { $dbport = $ARGV[ ++$i ]; last; };
+
+ # Set the users password
+ /^--password=/ && do {
+ $dbpass = $ARGV[$i];
+ $dbpass =~ s/^--password=//g;
+ last;
+ };
+
+ # Set the base of the filename. The extensions pulled
+ # from the templates will be appended to this name
+ /^-f$/ && do {
+ $output_filename_base = $ARGV[ ++$i ];
+ $fileisset = 1;
+ last;
+ };
+
+ # Set the template directory explicitly
+ /^(-l|--library)$/ && do {
+ $template_path = $ARGV[ ++$i ];
+ last;
+ };
+
+ # Set the output type
+ /^(-t|--type)$/ && do {
+ $wanted_output = $ARGV[ ++$i ];
+ last;
+ };
+
+ # User has requested a single schema dump and provided a pattern
+ /^(-s|--schema)$/ && do {
+ $only_schema = $ARGV[ ++$i ];
+ last;
+ };
+
+ # Check to see if Statistics have been requested
+ /^--statistics$/ && do {
+ $statistics = 1;
+ last;
+ };
+
+ # Help is wanted, redirect user to usage()
+ /^-\?$/ && do { usage( $basename, $database, $dbuser ); last; };
+ /^--help$/ && do { usage( $basename, $database, $dbuser ); last; };
+ }
+ }
-# If no arguments have been provided, connect to the database anyway but
-# inform the user of what we're doing.
-if ( $#ARGV <= 0 ) {
- print <<Msg
+ # If no arguments have been provided, connect to the database anyway but
+ # inform the user of what we're doing.
+ if ( $#ARGV <= 0 ) {
+ print <<Msg
No arguments set. Use '$basename --help' for help
Connecting to database '$database' as user '$dbuser'
Msg
-;
-}
-
+ ;
+ }
-# Database Connection
-my $dsn = "dbi:Pg:dbname=$database";
-$dsn .= ";host=$dbhost" if ( "$dbhost" ne "" );
-$dsn .= ";port=$dbport" if ( "$dbport" ne "" );
-my $dbh = DBI->connect( $dsn, $dbuser, $dbpass )
- or triggerError("Unable to connect due to: $DBD::Pg::errstr");
-
-# Always disconnect from the database if a database handle is setup
-END {
- $dbh->disconnect() if $dbh;
-}
+ # Database Connection
+ my $dsn = "dbi:Pg:dbname=$database";
+ $dsn .= ";host=$dbhost" if ( "$dbhost" ne "" );
+ $dsn .= ";port=$dbport" if ( "$dbport" ne "" );
+ my $dbh = DBI->connect( $dsn, $dbuser, $dbpass )
+ or triggerError("Unable to connect due to: $DBI::errstr");
-# PostgreSQL's version is used to determine what queries are required
-# to retrieve a given information set.
-my $sql_GetVersion = qq{
- SELECT cast(substr(version(), 12, 1) as integer) * 10000
- + cast(substr(version(), 14, 1) as integer) * 100
- as version;
-};
+ info_collect( $dbh, \%db, $database, $only_schema, $statistics );
-my $sth_GetVersion = $dbh->prepare($sql_GetVersion);
-$sth_GetVersion->execute();
-my $version = $sth_GetVersion->fetchrow_hashref;
-my $pgversion = $version->{'version'};
+ $dbh->disconnect() if $dbh;
-# Ensure we only get information for the requested schemas.
-#
-# system_schema -> The primary system schema for a database.
-# Public is used for verions prior to 7.3
-#
-# system_schema_list -> The list of schemas which we are not supposed
-# to gather information for.
-# TODO: Merge with system_schema in array form.
-#
-# schemapattern -> The schema the user provided as a command
-# line option.
-my $schemapattern = '^';
-my $system_schema;
-my $system_schema_list;
-if ( $pgversion >= 70300 ) {
- $system_schema = 'pg_catalog';
- $system_schema_list = 'pg_catalog|information_schema';
- if (defined($only_schema)) {
- $schemapattern = '^'. $only_schema .'$';
- }
-}
-else {
- $system_schema = 'public';
- $system_schema_list = $system_schema;
-}
+ # Write out *ALL* templates
+ write_using_templates( \%db, $database, $statistics, $template_path,
+ $output_filename_base, $wanted_output );
+} ## end sub main($)
+##
+# info_collect
#
-# List of queries which are used to gather information from the
-# database. The queries differ based on version but should
-# provide similar output. At some point it should be safe to remove
-# support for older database versions.
-#
-my $sql_Columns;
-my $sql_Constraint;
-my $sql_Database;
-my $sql_Foreign_Keys;
-my $sql_Foreign_Key_Arg;
-my $sql_Function;
-my $sql_FunctionArg;
-my $sql_Indexes;
-my $sql_Primary_Keys;
-my $sql_Schema;
-my $sql_Tables;
-my $sql_Table_Statistics;
-
-# Pull out a list of tables, views and special structures.
-if ( $pgversion >= 70300 ) {
- $sql_Tables = qq{
+# Pull out all of the applicable information about a specific database
+sub info_collect($$$$$)
+{
+ my ( $dbh, $db, $database, $only_schema, $statistics ) = @_;
+
+ my %struct;
+ $db->{$database}{'STRUCT'} = \%struct;
+ my $struct = $db->{$database}{'STRUCT'};
+
+ # PostgreSQL's version is used to determine what queries are required
+ # to retrieve a given information set.
+ my $sql_GetVersion = qq{
+ SELECT cast(substr(version(), 12, 1) as integer) * 10000
+ + cast(substr(version(), 14, 1) as integer) * 100
+ AS version;
+ };
+
+ my $sth_GetVersion = $dbh->prepare($sql_GetVersion);
+ $sth_GetVersion->execute();
+ my $version = $sth_GetVersion->fetchrow_hashref;
+ my $pgversion = $version->{'version'};
+
+ # Ensure we only retrieve information for the requested schemas.
+ #
+ # system_schema -> The primary system schema for a database.
+ # Public is used for verions prior to 7.3
+ #
+ # system_schema_list -> The list of schemas which we are not supposed
+ # to gather information for.
+ # TODO: Merge with system_schema in array form.
+ #
+ # schemapattern -> The schema the user provided as a command
+ # line option.
+ my $schemapattern = '^';
+ my $system_schema;
+ my $system_schema_list;
+ if ( $pgversion >= 70300 ) {
+ $system_schema = 'pg_catalog';
+ $system_schema_list =
+ 'pg_catalog|pg_toast|pg_temp_[0-9]+|information_schema';
+ if ( defined($only_schema) ) {
+ $schemapattern = '^' . $only_schema . '$';
+ }
+ }
+ else {
+ $system_schema = 'public';
+ $system_schema_list = $system_schema;
+ }
+
+ #
+ # List of queries which are used to gather information from the
+ # database. The queries differ based on version but should
+ # provide similar output. At some point it should be safe to remove
+ # support for older database versions.
+ #
+ my $sql_Columns;
+ my $sql_Constraint;
+ my $sql_Database;
+ my $sql_Foreign_Keys;
+ my $sql_Foreign_Key_Arg;
+ my $sql_Function;
+ my $sql_FunctionArg;
+ my $sql_Indexes;
+ my $sql_Primary_Keys;
+ my $sql_Schema;
+ my $sql_Tables;
+ my $sql_Table_Statistics;
+
+ # Pull out a list of tables, views and special structures.
+ if ( $pgversion >= 70300 ) {
+ $sql_Tables = qq{
SELECT nspname as namespace
, relname as tablename
, pg_catalog.pg_get_userbyid(relowner) AS tableowner
AND nspname ~ '$schemapattern';
};
- # - uses pg_class.oid
- $sql_Columns = qq{
+ # - uses pg_class.oid
+ $sql_Columns = qq{
SELECT attname as column_name
, attlen as column_length
, CASE
AND attrelid = ?;
};
-}
-elsif ( $pgversion >= 70200 ) {
- $sql_Tables = qq{
+ }
+ elsif ( $pgversion >= 70200 ) {
+ $sql_Tables = qq{
SELECT 'public' as namespace
, relname as tablename
, pg_get_userbyid(relowner) AS tableowner
AND relname NOT LIKE 'pg_%';
};
- # - uses pg_class.oid
- $sql_Columns = qq{
+ # - uses pg_class.oid
+ $sql_Columns = qq{
SELECT attname as column_name
, attlen as column_length
, CASE
AND attrelid = ?;
};
-}
-else {
- # 7.1 or earlier has a different description structure
+ }
+ else {
+
+ # 7.1 or earlier has a different description structure
- $sql_Tables = qq{
+ $sql_Tables = qq{
SELECT 'public' as namespace
, relname as tablename
, pg_get_userbyid(relowner) AS tableowner
AND relname NOT LIKE 'pg_%';
};
- # - uses pg_class.oid
- $sql_Columns = qq{
+ # - uses pg_class.oid
+ $sql_Columns = qq{
SELECT attname as column_name
, attlen as column_length
, CASE
WHERE attnum > 0
AND attrelid = ?;
};
-}
+ }
-if ($statistics == 1)
-{
- if ($pgversion <= 70300) {
- triggerError("Table statistics supported on PostgreSQL 7.4 and later.\nRemove --statistics flag and try again.");
- }
+ if ( $statistics == 1 ) {
+ if ( $pgversion <= 70300 ) {
+ triggerError(
+"Table statistics supported on PostgreSQL 7.4 and later.\nRemove --statistics flag and try again."
+ );
+ }
- $sql_Table_Statistics = qq{
+ $sql_Table_Statistics = qq{
SELECT table_len
, tuple_count
, tuple_len
, CAST(free_percent AS numeric(20,2)) AS free_percent
FROM pgstattuple(CAST(? AS oid));
};
-}
+ }
-if ($pgversion >= 70300)
-{
- $sql_Indexes = qq{
+ if ( $pgversion >= 70300 ) {
+ $sql_Indexes = qq{
SELECT schemaname
, tablename
, indexname
AND schemaname = ?
AND tablename = ?;
};
-} else {
- $sql_Indexes = qq{
+ }
+ else {
+ $sql_Indexes = qq{
SELECT NULL AS schemaname
, NULL AS tablename
, NULL AS indexname
, NULL AS indexdef
WHERE TRUE = FALSE AND ? = ?;
};
-}
-
+ }
-# Fetch the list of PRIMARY and UNIQUE keys
-if ($pgversion >= 70300)
-{
- $sql_Primary_Keys = qq{
+ # Fetch the list of PRIMARY and UNIQUE keys
+ if ( $pgversion >= 70300 ) {
+ $sql_Primary_Keys = qq{
SELECT conname AS constraint_name
, pg_catalog.pg_get_indexdef(d.objid) AS constraint_definition
, CASE
AND conrelid = ?;
};
-} else {
- # - uses pg_class.oid
- $sql_Primary_Keys = qq{
+ }
+ else {
+
+ # - uses pg_class.oid
+ $sql_Primary_Keys = qq{
SELECT i.relname AS constraint_name
, pg_get_indexdef(pg_index.indexrelid) AS constraint_definition
, CASE
AND pg_index.indisunique
AND pg_index.indrelid = ?;
};
-}
-
-# FOREIGN KEY fetch
-#
-# Don't return the constraint name if it was automatically generated by
-# PostgreSQL. The $N (where N is an integer) is not a descriptive enough
-# piece of information to be worth while including in the various outputs.
-if ( $pgversion >= 70300 ) {
- $sql_Foreign_Keys = qq{
+ }
+
+ # FOREIGN KEY fetch
+ #
+ # Don't return the constraint name if it was automatically generated by
+ # PostgreSQL. The $N (where N is an integer) is not a descriptive enough
+ # piece of information to be worth while including in the various outputs.
+ if ( $pgversion >= 70300 ) {
+ $sql_Foreign_Keys = qq{
SELECT pg_constraint.oid
, pg_namespace.nspname AS namespace
, CASE WHEN substring(pg_constraint.conname FROM 1 FOR 1) = '\$' THEN ''
AND pn.nspname ~ '$schemapattern';
};
- $sql_Foreign_Key_Arg = qq{
+ $sql_Foreign_Key_Arg = qq{
SELECT attname AS attribute_name
, relname AS relation_name
, nspname AS namespace
WHERE attrelid = ?
AND attnum = ?;
};
-}
-else {
- # - uses pg_class.oid
- $sql_Foreign_Keys = q{
+ }
+ else {
+
+ # - uses pg_class.oid
+ $sql_Foreign_Keys = q{
SELECT oid
, 'public' AS namespace
, CASE WHEN substring(tgname from 1 for 1) = '$' THEN ''
AND tgrelid = ?;
};
- $sql_Foreign_Key_Arg = qq{SELECT TRUE WHERE ? = 0 and ? = 0;};
-}
+ $sql_Foreign_Key_Arg = qq{SELECT TRUE WHERE ? = 0 and ? = 0;};
+ }
-# Fetch CHECK constraints
-if ( $pgversion >= 70400 ) {
- $sql_Constraint = qq{
+ # Fetch CHECK constraints
+ if ( $pgversion >= 70400 ) {
+ $sql_Constraint = qq{
SELECT pg_get_constraintdef(oid) AS constraint_source
, conname AS constraint_name
FROM pg_constraint
WHERE conrelid = ?
AND contype = 'c';
};
-}
-elsif ( $pgversion >= 70300 ) {
- $sql_Constraint = qq{
+ }
+ elsif ( $pgversion >= 70300 ) {
+ $sql_Constraint = qq{
SELECT 'CHECK ' || pg_catalog.substr(consrc, 2, length(consrc) - 2) AS constraint_source
, conname AS constraint_name
FROM pg_constraint
WHERE conrelid = ?
AND contype = 'c';
};
-}
-else {
- $sql_Constraint = qq{
+ }
+ else {
+ $sql_Constraint = qq{
SELECT 'CHECK ' || substr(rcsrc, 2, length(rcsrc) - 2) AS constraint_source
, rcname AS constraint_name
FROM pg_relcheck
WHERE rcrelid = ?;
};
-}
+ }
-# Query for function information
-if ( $pgversion >= 80000 ) {
- $sql_Function = qq{
+ # Query for function information
+ if ( $pgversion >= 80000 ) {
+ $sql_Function = qq{
SELECT proname AS function_name
, nspname AS namespace
, lanname AS language_name
AND proname != 'plpgsql_call_handler';
};
- $sql_FunctionArg = qq{
+ $sql_FunctionArg = qq{
SELECT nspname AS namespace
, replace(pg_catalog.format_type(pg_type.oid, typtypmod)
, nspname ||'.'
JOIN pg_catalog.pg_namespace ON (pg_namespace.oid = typnamespace)
WHERE pg_type.oid = ?;
};
-} elsif ( $pgversion >= 70300 ) {
- $sql_Function = qq{
+ }
+ elsif ( $pgversion >= 70300 ) {
+ $sql_Function = qq{
SELECT proname AS function_name
, nspname AS namespace
, lanname AS language_name
AND proname != 'plpgsql_call_handler';
};
- $sql_FunctionArg = qq{
+ $sql_FunctionArg = qq{
SELECT nspname AS namespace
, replace(pg_catalog.format_type(pg_type.oid, typtypmod)
, nspname ||'.'
JOIN pg_catalog.pg_namespace ON (pg_namespace.oid = typnamespace)
WHERE pg_type.oid = ?;
};
-}
-else {
- $sql_Function = qq{
+ }
+ else {
+ $sql_Function = qq{
SELECT proname AS function_name
, 'public' AS namespace
, lanname AS language_name
AND proname != 'plpgsql_call_handler';
};
- $sql_FunctionArg = qq{
+ $sql_FunctionArg = qq{
SELECT 'public' AS namespace
, format_type(pg_type.oid, typtypmod) AS type_name
FROM pg_type
WHERE pg_type.oid = ?;
};
-}
+ }
-# Fetch schema information.
-if ( $pgversion >= 70300 ) {
- $sql_Schema = qq{
+ # Fetch schema information.
+ if ( $pgversion >= 70300 ) {
+ $sql_Schema = qq{
SELECT pg_catalog.obj_description(oid, 'pg_namespace') AS comment
, nspname as namespace
- FROM pg_catalog.pg_namespace;
+ FROM pg_catalog.pg_namespace
+ WHERE pg_namespace.nspname !~ '$system_schema_list'
+ AND pg_namespace.nspname ~ '$schemapattern';
};
-}
-else {
- # In PostgreSQL 7.2 and prior, schemas were not a part of the system.
- # Dummy query returns no rows to prevent added logic later on.
- $sql_Schema = qq{SELECT TRUE WHERE TRUE = FALSE;};
-}
+ }
+ else {
+
+ # In PostgreSQL 7.2 and prior, schemas were not a part of the system.
+ # Dummy query returns no rows to prevent added logic later on.
+ $sql_Schema = qq{SELECT TRUE WHERE TRUE = FALSE;};
+ }
-# Fetch the description of the database
-if ($pgversion >= 70300) {
- $sql_Database = qq{
+ # Fetch the description of the database
+ if ( $pgversion >= 70300 ) {
+ $sql_Database = qq{
SELECT pg_catalog.obj_description(oid, 'pg_database') as comment
FROM pg_catalog.pg_database
WHERE datname = '$database';
};
-}
-elsif ($pgversion == 70200) {
- $sql_Database = qq{
+ }
+ elsif ( $pgversion == 70200 ) {
+ $sql_Database = qq{
SELECT obj_description(oid, 'pg_database') as comment
FROM pg_database
WHERE datname = '$database';
};
-}
-else {
- # In PostgreSQL 7.1, the database did not have comment support
- $sql_Database = qq{ SELECT TRUE as comment WHERE TRUE = FALSE;};
-}
+ }
+ else {
+
+ # In PostgreSQL 7.1, the database did not have comment support
+ $sql_Database = qq{ SELECT TRUE as comment WHERE TRUE = FALSE;};
+ }
+
+ my $sth_Columns = $dbh->prepare($sql_Columns);
+ my $sth_Constraint = $dbh->prepare($sql_Constraint);
+ my $sth_Database = $dbh->prepare($sql_Database);
+ my $sth_Foreign_Keys = $dbh->prepare($sql_Foreign_Keys);
+ my $sth_Foreign_Key_Arg = $dbh->prepare($sql_Foreign_Key_Arg);
+ my $sth_Function = $dbh->prepare($sql_Function);
+ my $sth_FunctionArg = $dbh->prepare($sql_FunctionArg);
+ my $sth_Indexes = $dbh->prepare($sql_Indexes);
+ my $sth_Primary_Keys = $dbh->prepare($sql_Primary_Keys);
+ my $sth_Schema = $dbh->prepare($sql_Schema);
+ my $sth_Tables = $dbh->prepare($sql_Tables);
+ my $sth_Table_Statistics = $dbh->prepare($sql_Table_Statistics);
+
+ # Fetch Database info
+ $sth_Database->execute();
+ my $dbinfo = $sth_Database->fetchrow_hashref;
+ if ( defined($dbinfo) ) {
+ $db->{$database}{'COMMENT'} = $dbinfo->{'comment'};
+ }
+
+ # Fetch tables and all things bound to tables
+ $sth_Tables->execute();
+ while ( my $tables = $sth_Tables->fetchrow_hashref ) {
+ my $reloid = $tables->{'oid'};
+ my $relname = $tables->{'tablename'};
+
+ my $schema = $tables->{'namespace'};
+
+ EXPRESSIONFOUND:
+
+ # Store permissions
+ my $acl = $tables->{'relacl'};
+
+ # Empty acl groups cause serious issues.
+ $acl ||= '';
+
+ # Strip array forming 'junk'.
+ $acl =~ s/^{//g;
+ $acl =~ s/}$//g;
+ $acl =~ s/"//g;
+
+ # Foreach acl
+ foreach ( split( /\,/, $acl ) ) {
+ my ( $user, $raw_permissions ) = split( /=/, $_ );
+
+ if ( defined($raw_permissions) ) {
+ if ( $user eq '' ) {
+ $user = 'PUBLIC';
+ }
+
+ # The section after the / is the user who granted the permissions
+ my ( $permissions, $granting_user ) =
+ split( /\//, $raw_permissions );
+
+ # Break down permissions to individual flags
+ if ( $permissions =~ /a/ ) {
+ $struct->{$schema}{'TABLE'}{$relname}{'ACL'}{$user}
+ {'INSERT'} = 1;
+ }
+
+ if ( $permissions =~ /r/ ) {
+ $struct->{$schema}{'TABLE'}{$relname}{'ACL'}{$user}
+ {'SELECT'} = 1;
+ }
+
+ if ( $permissions =~ /w/ ) {
+ $struct->{$schema}{'TABLE'}{$relname}{'ACL'}{$user}
+ {'UPDATE'} = 1;
+ }
+
+ if ( $permissions =~ /d/ ) {
+ $struct->{$schema}{'TABLE'}{$relname}{'ACL'}{$user}
+ {'DELETE'} = 1;
+ }
+
+ if ( $permissions =~ /R/ ) {
+ $struct->{$schema}{'TABLE'}{$relname}{'ACL'}{$user}
+ {'RULE'} = 1;
+ }
+
+ if ( $permissions =~ /x/ ) {
+ $struct->{$schema}{'TABLE'}{$relname}{'ACL'}{$user}
+ {'REFERENCES'} = 1;
+ }
+
+ if ( $permissions =~ /t/ ) {
+ $struct->{$schema}{'TABLE'}{$relname}{'ACL'}{$user}
+ {'TRIGGER'} = 1;
+ }
+ }
+ }
-my $sth_Columns = $dbh->prepare($sql_Columns);
-my $sth_Constraint = $dbh->prepare($sql_Constraint);
-my $sth_Database = $dbh->prepare($sql_Database);
-my $sth_Foreign_Keys = $dbh->prepare($sql_Foreign_Keys);
-my $sth_Foreign_Key_Arg = $dbh->prepare($sql_Foreign_Key_Arg);
-my $sth_Function = $dbh->prepare($sql_Function);
-my $sth_FunctionArg = $dbh->prepare($sql_FunctionArg);
-my $sth_Indexes = $dbh->prepare($sql_Indexes);
-my $sth_Primary_Keys = $dbh->prepare($sql_Primary_Keys);
-my $sth_Schema = $dbh->prepare($sql_Schema);
-my $sth_Tables = $dbh->prepare($sql_Tables);
-my $sth_Table_Statistics = $dbh->prepare($sql_Table_Statistics);
-
-my %structure;
-my %struct;
-
-# Fetch Database info
-$sth_Database->execute();
-my $dbinfo = $sth_Database->fetchrow_hashref;
-if ( defined($dbinfo) ) {
- $struct{'DATABASE'}{$database}{'COMMENT'} = $dbinfo->{'comment'};
-}
+ # Primitive Stats, but only if requested
+ if ( $statistics == 1 ) {
+ $sth_Table_Statistics->execute($reloid);
+
+ my $stats = $sth_Table_Statistics->fetchrow_hashref;
+
+ $struct->{$schema}{'TABLE'}{$relname}{'TABLELEN'} =
+ $stats->{'table_len'};
+ $struct->{$schema}{'TABLE'}{$relname}{'TUPLECOUNT'} =
+ $stats->{'tuple_count'};
+ $struct->{$schema}{'TABLE'}{$relname}{'TUPLELEN'} =
+ $stats->{'tuple_len'};
+ $struct->{$schema}{'TABLE'}{$relname}{'DEADTUPLELEN'} =
+ $stats->{'dead_tuple_len'};
+ $struct->{$schema}{'TABLE'}{$relname}{'FREELEN'} =
+ $stats->{'free_space'};
+ }
-# Fetch tables and all things bound to tables
-$sth_Tables->execute();
-while ( my $tables = $sth_Tables->fetchrow_hashref ) {
- my $reloid = $tables->{'oid'};
- my $relname = $tables->{'tablename'};
-
- my $group = $tables->{'namespace'};
-
- EXPRESSIONFOUND:
-
- # Store permissions
- my $acl = $tables->{'relacl'};
-
- # Empty acl groups cause serious issues.
- $acl ||= '';
-
- # Strip array forming 'junk'.
- $acl =~ s/^{//g;
- $acl =~ s/}$//g;
- $acl =~ s/"//g;
-
- # Foreach acl
- foreach ( split ( /\,/, $acl ) ) {
- my ( $user, $raw_permissions ) = split ( /=/, $_ );
-
- if ( defined($raw_permissions) ) {
- if ( $user eq '' ) {
- $user = 'PUBLIC';
- }
-
- # The section after the / is the user who granted the permissions
- my ( $permissions, $granting_user) = split ( /\//, $raw_permissions );
-
- # Break down permissions to individual flags
- if ( $permissions =~ /a/ ) {
- $structure{$group}{$relname}{'ACL'}{$user}{'INSERT'} = 1;
- }
-
- if ( $permissions =~ /r/ ) {
- $structure{$group}{$relname}{'ACL'}{$user}{'SELECT'} = 1;
- }
-
- if ( $permissions =~ /w/ ) {
- $structure{$group}{$relname}{'ACL'}{$user}{'UPDATE'} = 1;
- }
-
- if ( $permissions =~ /d/ ) {
- $structure{$group}{$relname}{'ACL'}{$user}{'DELETE'} = 1;
- }
-
- if ( $permissions =~ /R/ ) {
- $structure{$group}{$relname}{'ACL'}{$user}{'RULE'} = 1;
- }
-
- if ( $permissions =~ /x/ ) {
- $structure{$group}{$relname}{'ACL'}{$user}{'REFERENCES'} = 1;
- }
-
- if ( $permissions =~ /t/ ) {
- $structure{$group}{$relname}{'ACL'}{$user}{'TRIGGER'} = 1;
- }
- }
- }
-
- # Primitive Stats, but only if requested
- if ($statistics == 1)
- {
- $sth_Table_Statistics->execute($reloid);
-
- my $stats = $sth_Table_Statistics->fetchrow_hashref;
-
- $structure{$group}{$relname}{'TABLELEN'} = $stats->{'table_len'};
- $structure{$group}{$relname}{'TUPLECOUNT'} = $stats->{'tuple_count'};
- $structure{$group}{$relname}{'TUPLELEN'} = $stats->{'tuple_len'};
- $structure{$group}{$relname}{'DEADTUPLELEN'} = $stats->{'dead_tuple_len'};
- $structure{$group}{$relname}{'FREELEN'} = $stats->{'free_space'};
- }
-
- # Store the relation type
- $structure{$group}{$relname}{'TYPE'} = $tables->{'reltype'};
-
- # Store table description
- $structure{$group}{$relname}{'DESCRIPTION'} = $tables->{'table_description'};
-
- # Store the view definition
- $structure{$group}{$relname}{'VIEW_DEF'} = $tables->{'view_definition'};
-
- # Store constraints
- $sth_Constraint->execute($reloid);
- while ( my $cols = $sth_Constraint->fetchrow_hashref ) {
- my $constraint_name = $cols->{'constraint_name'};
- $structure{$group}{$relname}{'CONSTRAINT'}{$constraint_name} =
- $cols->{'constraint_source'};
- }
-
- $sth_Columns->execute($reloid);
- my $i = 1;
- while ( my $cols = $sth_Columns->fetchrow_hashref ) {
- my $column_name = $cols->{'column_name'};
- $structure{$group}{$relname}{'COLUMN'}{$column_name}{'ORDER'} =
- $cols->{'attnum'};
- $structure{$group}{$relname}{'COLUMN'}{$column_name}{'PRIMARY KEY'} =
- 0;
- $structure{$group}{$relname}{'COLUMN'}{$column_name}{'FKTABLE'} = '';
- $structure{$group}{$relname}{'COLUMN'}{$column_name}{'TYPE'} =
- $cols->{'column_type'};
- $structure{$group}{$relname}{'COLUMN'}{$column_name}{'NULL'} =
- $cols->{'column_null'};
- $structure{$group}{$relname}{'COLUMN'}{$column_name}{'DESCRIPTION'} =
- $cols->{'column_description'};
- $structure{$group}{$relname}{'COLUMN'}{$column_name}{'DEFAULT'} =
- $cols->{'column_default'};
- }
-
- # Pull out both PRIMARY and UNIQUE keys based on the supplied query
- # and the relation OID.
- #
- # Since there may be multiple UNIQUE indexes on a table, we append a
- # number to the end of the the UNIQUE keyword which shows that they
- # are a part of a related definition. I.e UNIQUE_1 goes with UNIQUE_1
- #
- $sth_Primary_Keys->execute($reloid);
- my $unqgroup = 0;
- while ( my $pricols = $sth_Primary_Keys->fetchrow_hashref ) {
- my $index_type = $pricols->{'constraint_type'};
- my $con = $pricols->{'constraint_name'};
- my $indexdef = $pricols->{'constraint_definition'};
-
- # Fetch the column list
- my $column_list = $indexdef;
- $column_list =~ s/.*\(([^)]+)\).*/$1/g;
-
- # Split our column list and deal with all PRIMARY KEY fields
- my @collist = split(',', $column_list);
-
- # Store the column number in the indextype field. Anything > 0 indicates
- # the column has this type of constraint applied to it.
- my $column;
- my $currentcol = $#collist + 1;
- my $numcols = $#collist + 1;
-
- # Bump group number if there are two or more columns
- if ($numcols >= 2 && $index_type eq 'UNIQUE') {
- $unqgroup++;
- }
-
- # Record the data to the structure.
- while ($column = pop(@collist) ) {
- $column =~ s/\s$//;
- $column =~ s/^\s//;
- $column =~ s/^"//;
- $column =~ s/"$//;
-
- $structure{$group}{$relname}{'COLUMN'}{$column}{'CON'}{$con}{'TYPE'} = $index_type;
-
- $structure{$group}{$relname}{'COLUMN'}{$column}{'CON'}{$con}{'COLNUM'} = $currentcol--;
-
- # Record group number only when a multi-column constraint is involved
- if ($numcols >= 2 && $index_type eq 'UNIQUE') {
- $structure{$group}{$relname}{'COLUMN'}{$column}{'CON'}{$con}{'KEYGROUP'} = $unqgroup;
- }
- }
- }
-
- # FOREIGN KEYS like UNIQUE indexes can appear several times in a table in multi-column
- # format. We use the same trick to record a numeric association to the foreign key
- # reference.
- #
- $sth_Foreign_Keys->execute($reloid);
- my $fkgroup = 0;
- while (my $forcols = $sth_Foreign_Keys->fetchrow_hashref)
- {
- my $column_oid = $forcols->{'oid'};
- my $con = $forcols->{'constraint_name'};
-
- # Declare variables for dataload
- my @keylist;
- my @fkeylist;
- my $fgroup;
- my $ftable;
-
- if ($pgversion >= 70300) {
- my $fkey = $forcols->{'constraint_fkey'};
- my $keys = $forcols->{'constraint_key'};
- my $frelid = $forcols->{'foreignrelid'};
-
- # Since decent array support was not added to 7.4, and we want to support
- # 7.3 as well, we parse the text version of the array by hand rather than
- # combining this and Foreign_Key_Arg query into a single query.
- $fkey =~ s/^{//g;
- $fkey =~ s/}$//g;
- $fkey =~ s/"//g;
-
- $keys =~ s/^{//g;
- $keys =~ s/}$//g;
- $keys =~ s/"//g;
-
- my @keyset = split (/,/, $keys);
- my @fkeyset = split (/,/, $fkey);
-
- # Convert the list of column numbers into column names for the
- # local side.
- foreach my $k (@keyset)
- {
- $sth_Foreign_Key_Arg->execute($reloid, $k);
-
- my $row = $sth_Foreign_Key_Arg->fetchrow_hashref;
-
- push(@keylist, $row->{'attribute_name'});
- }
-
- # Convert the list of columns numbers into column names for the
- # referenced side. Grab the table and namespace while we're here.
- foreach my $k (@fkeyset)
- {
- $sth_Foreign_Key_Arg->execute($frelid, $k);
-
- my $row = $sth_Foreign_Key_Arg->fetchrow_hashref;
-
- push(@fkeylist, $row->{'attribute_name'});
- $fgroup = $row->{'namespace'};
- $ftable = $row->{'relation_name'};
- }
-
- # Deal with common catalog issues.
- die "FKEY $con Broken -- fix your PostgreSQL installation" if $#keylist != $#fkeylist;
- }
- else {
- my $keyname; # Throw away
- my $table; # Throw away
- my $unspecified; # Throw away
- my @columns;
-
- my $nargs = $forcols->{'number_args'};
- my $args = $forcols->{'args'};
-
- # This database doesn't support namespaces, so use the default
- $fgroup = $system_schema;
-
- ($keyname, $table, $ftable, $unspecified, @columns) = split(/\000/, $args);
-
- # Account for old versions which don't handle NULL but instead return a string
- # of the escape sequence
- if (!defined($ftable)) {
- ($keyname, $table, $ftable, $unspecified, @columns) = split (/\\000/, $args);
- }
-
- # Push the column list stored into @columns into the key and fkey lists
- while (my $column = pop (@columns)
- and my $fcolumn = pop (@columns))
- {
- push(@keylist, $column);
- push(@fkeylist, $fcolumn);
- }
- }
-
- #
- # Load up the array based on the information discovered using the information
- # retrieval methods above.
- #
- my $numcols = $#keylist + 1;
- my $currentcol = $#keylist + 1;
-
- # Bump group number if there are two or more columns involved
- if ($numcols >= 2) {
- $fkgroup++;
- }
-
- # Record the foreign key to structure
- while (my $column = pop(@keylist)
- and my $fkey = pop(@fkeylist))
- {
- $structure{$group}{$relname}{'COLUMN'}{$column}{'CON'}{$con}{'TYPE'} = 'FOREIGN KEY';
-
- $structure{$group}{$relname}{'COLUMN'}{$column}{'CON'}{$con}{'COLNUM'} = $currentcol--;
-
- $structure{$group}{$relname}{'COLUMN'}{$column}{'CON'}{$con}{'FKTABLE'} = $ftable;
- $structure{$group}{$relname}{'COLUMN'}{$column}{'CON'}{$con}{'FKSCHEMA'} = $fgroup;
- $structure{$group}{$relname}{'COLUMN'}{$column}{'CON'}{$con}{'FK-COL NAME'} = $fkey;
-
- # Record group number only when a multi-column constraint is involved
- if ($numcols >= 2) {
- $structure{$group}{$relname}{'COLUMN'}{$column}{'CON'}{$con}{'KEYGROUP'} = $fkgroup;
- }
- }
- }
-
- # Pull out index information
- $sth_Indexes->execute($group, $relname);
- while (my $idx = $sth_Indexes->fetchrow_hashref)
- {
- $structure{$group}{$relname}{'INDEX'}{$idx->{'indexname'}} = $idx->{'indexdef'};
- }
-}
+ # Store the relation type
+ $struct->{$schema}{'TABLE'}{$relname}{'TYPE'} = $tables->{'reltype'};
+
+ # Store table description
+ $struct->{$schema}{'TABLE'}{$relname}{'DESCRIPTION'} =
+ $tables->{'table_description'};
+
+ # Store the view definition
+ $struct->{$schema}{'TABLE'}{$relname}{'VIEW_DEF'} =
+ $tables->{'view_definition'};
-# Function Handling
-$sth_Function->execute();
-while ( my $functions = $sth_Function->fetchrow_hashref ) {
- my $functionname = $functions->{'function_name'} . '( ';
- my $group = $functions->{'namespace'};
- my $comment = $functions->{'comment'};
- my $functionargs = $functions->{'function_args'};
- my @types = split ( ' ', $functionargs );
- my $count = 0;
-
- # Pre-setup argument names when available.
- my $argnames = $functions->{'function_arg_names'};
- $argnames =~ s/{(.*)}/\1/;
- my @names=split(',',$argnames);
-
- # Setup full argument types -- including the name prefix
- foreach my $type (@types) {
- $sth_FunctionArg->execute($type);
-
- my $hash = $sth_FunctionArg->fetchrow_hashref;
-
- if ( $count > 0 ) {
- $functionname .= ', ';
- }
-
- if (scalar(@names) > 0) {
- $functionname .= $names[$count] .' ';
+ # Store constraints
+ $sth_Constraint->execute($reloid);
+ while ( my $cols = $sth_Constraint->fetchrow_hashref ) {
+ my $constraint_name = $cols->{'constraint_name'};
+ $struct->{$schema}{'TABLE'}{$relname}{'CONSTRAINT'}
+ {$constraint_name} = $cols->{'constraint_source'};
}
- if ( $hash->{'namespace'} ne $system_schema ) {
- $functionname .= $hash->{'namespace'} . '.';
- }
- $functionname .= $hash->{'type_name'};
-
- $count++;
- }
- $functionname .= ' )';
-
- my $ret_type = $functions->{'returns_set'} ? 'SET OF ' : '';
- $sth_FunctionArg->execute($functions->{'return_type'});
- my $rhash = $sth_FunctionArg->fetchrow_hashref;
- $ret_type .= $rhash->{'type_name'};
-
- $struct{'FUNCTION'}{$group}{$functionname}{'COMMENT'} = $comment;
- $struct{'FUNCTION'}{$group}{$functionname}{'SOURCE'} = $functions->{'source_code'};
- $struct{'FUNCTION'}{$group}{$functionname}{'LANGUAGE'} = $functions->{'language_name'};
- $struct{'FUNCTION'}{$group}{$functionname}{'RETURNS'} = $ret_type;
-}
+ $sth_Columns->execute($reloid);
+ my $i = 1;
+ while ( my $cols = $sth_Columns->fetchrow_hashref ) {
+ my $column_name = $cols->{'column_name'};
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column_name}
+ {'ORDER'} = $cols->{'attnum'};
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column_name}
+ {'PRIMARY KEY'} = 0;
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column_name}
+ {'FKTABLE'} = '';
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column_name}
+ {'TYPE'} = $cols->{'column_type'};
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column_name}
+ {'NULL'} = $cols->{'column_null'};
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column_name}
+ {'DESCRIPTION'} = $cols->{'column_description'};
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column_name}
+ {'DEFAULT'} = $cols->{'column_default'};
+ }
-# Deal with the Schema
-$sth_Schema->execute();
-while ( my $schema = $sth_Schema->fetchrow_hashref ) {
- my $comment = $schema->{'comment'};
- my $namespace = $schema->{'namespace'};
+ # Pull out both PRIMARY and UNIQUE keys based on the supplied query
+ # and the relation OID.
+ #
+ # Since there may be multiple UNIQUE indexes on a table, we append a
+ # number to the end of the the UNIQUE keyword which shows that they
+ # are a part of a related definition. I.e UNIQUE_1 goes with UNIQUE_1
+ #
+ $sth_Primary_Keys->execute($reloid);
+ my $unqgroup = 0;
+ while ( my $pricols = $sth_Primary_Keys->fetchrow_hashref ) {
+ my $index_type = $pricols->{'constraint_type'};
+ my $con = $pricols->{'constraint_name'};
+ my $indexdef = $pricols->{'constraint_definition'};
+
+ # Fetch the column list
+ my $column_list = $indexdef;
+ $column_list =~ s/.*\(([^)]+)\).*/$1/g;
+
+ # Split our column list and deal with all PRIMARY KEY fields
+ my @collist = split( ',', $column_list );
+
+ # Store the column number in the indextype field. Anything > 0
+ # indicates the column has this type of constraint applied to it.
+ my $column;
+ my $currentcol = $#collist + 1;
+ my $numcols = $#collist + 1;
+
+ # Bump group number if there are two or more columns
+ if ( $numcols >= 2 && $index_type eq 'UNIQUE' ) {
+ $unqgroup++;
+ }
+
+ # Record the data to the structure.
+ while ( $column = pop(@collist) ) {
+ $column =~ s/\s$//;
+ $column =~ s/^\s//;
+ $column =~ s/^"//;
+ $column =~ s/"$//;
+
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column}{'CON'}
+ {$con}{'TYPE'} = $index_type;
+
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column}{'CON'}
+ {$con}{'COLNUM'} = $currentcol--;
+
+ # Record group number only when a multi-column
+ # constraint is involved
+ if ( $numcols >= 2 && $index_type eq 'UNIQUE' ) {
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column}
+ {'CON'}{$con}{'KEYGROUP'} = $unqgroup;
+ }
+ }
+ }
- $struct{'SCHEMA'}{$namespace}{'COMMENT'} = $comment;
-}
+ # FOREIGN KEYS like UNIQUE indexes can appear several times in
+ # a table in multi-column format. We use the same trick to
+ # record a numeric association to the foreign key reference.
+ $sth_Foreign_Keys->execute($reloid);
+ my $fkgroup = 0;
+ while ( my $forcols = $sth_Foreign_Keys->fetchrow_hashref ) {
+ my $column_oid = $forcols->{'oid'};
+ my $con = $forcols->{'constraint_name'};
+
+ # Declare variables for dataload
+ my @keylist;
+ my @fkeylist;
+ my $fschema;
+ my $ftable;
+
+ if ( $pgversion >= 70300 ) {
+ my $fkey = $forcols->{'constraint_fkey'};
+ my $keys = $forcols->{'constraint_key'};
+ my $frelid = $forcols->{'foreignrelid'};
+
+ # Since decent array support was not added to 7.4, and
+ # we want to support 7.3 as well, we parse the text version
+ # of the array by hand rather than combining this and
+ # Foreign_Key_Arg query into a single query.
+ $fkey =~ s/^{//g;
+ $fkey =~ s/}$//g;
+ $fkey =~ s/"//g;
+
+ $keys =~ s/^{//g;
+ $keys =~ s/}$//g;
+ $keys =~ s/"//g;
+
+ my @keyset = split( /,/, $keys );
+ my @fkeyset = split( /,/, $fkey );
+
+ # Convert the list of column numbers into column names for the
+ # local side.
+ foreach my $k (@keyset) {
+ $sth_Foreign_Key_Arg->execute( $reloid, $k );
+
+ my $row = $sth_Foreign_Key_Arg->fetchrow_hashref;
+
+ push( @keylist, $row->{'attribute_name'} );
+ }
+
+ # Convert the list of columns numbers into column names
+ # for the referenced side. Grab the table and namespace
+ # while we're here.
+ foreach my $k (@fkeyset) {
+ $sth_Foreign_Key_Arg->execute( $frelid, $k );
+
+ my $row = $sth_Foreign_Key_Arg->fetchrow_hashref;
+
+ push( @fkeylist, $row->{'attribute_name'} );
+ $fschema = $row->{'namespace'};
+ $ftable = $row->{'relation_name'};
+ }
+
+ # Deal with common catalog issues.
+ die "FKEY $con Broken -- fix your PostgreSQL installation"
+ if $#keylist != $#fkeylist;
+ }
+ else {
+ my $keyname; # Throw away
+ my $table; # Throw away
+ my $unspecified; # Throw away
+ my @columns;
+
+ my $nargs = $forcols->{'number_args'};
+ my $args = $forcols->{'args'};
+
+ # This database doesn't support namespaces, so use the default
+ $fschema = $system_schema;
+
+ ( $keyname, $table, $ftable, $unspecified, @columns ) =
+ split( /\000/, $args );
+
+ # Account for old versions which don't handle NULL
+ # but instead return a string of the escape sequence
+ if ( !defined($ftable) ) {
+ ( $keyname, $table, $ftable, $unspecified, @columns ) =
+ split( /\\000/, $args );
+ }
+
+ # Push the column list stored into @columns into
+ # the key and fkey lists
+ while ( my $column = pop(@columns)
+ and my $fcolumn = pop(@columns) )
+ {
+ push( @keylist, $column );
+ push( @fkeylist, $fcolumn );
+ }
+ }
+
+ # Load up the array based on the information discovered
+ # using the information retrieval methods above.
+ my $numcols = $#keylist + 1;
+ my $currentcol = $#keylist + 1;
+
+ # Bump group number if there are two or more columns involved
+ if ( $numcols >= 2 ) {
+ $fkgroup++;
+ }
+
+ # Record the foreign key to structure
+ while ( my $column = pop(@keylist)
+ and my $fkey = pop(@fkeylist) )
+ {
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column}{'CON'}
+ {$con}{'TYPE'} = 'FOREIGN KEY';
+
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column}{'CON'}
+ {$con}{'COLNUM'} = $currentcol--;
+
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column}{'CON'}
+ {$con}{'FKTABLE'} = $ftable;
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column}{'CON'}
+ {$con}{'FKSCHEMA'} = $fschema;
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column}{'CON'}
+ {$con}{'FK-COL NAME'} = $fkey;
+
+ # Record group number only when a multi-column
+ # constraint is involved
+ if ( $numcols >= 2 ) {
+ $struct->{$schema}{'TABLE'}{$relname}{'COLUMN'}{$column}
+ {'CON'}{$con}{'KEYGROUP'} = $fkgroup;
+ }
+ }
+ }
+
+ # Pull out index information
+ $sth_Indexes->execute( $schema, $relname );
+ while ( my $idx = $sth_Indexes->fetchrow_hashref ) {
+ $struct->{$schema}{'TABLE'}{$relname}{'INDEX'}
+ { $idx->{'indexname'} } = $idx->{'indexdef'};
+ }
+ }
+
+ # Function Handling
+ $sth_Function->execute();
+ while ( my $functions = $sth_Function->fetchrow_hashref ) {
+ my $functionname = $functions->{'function_name'} . '( ';
+ my $schema = $functions->{'namespace'};
+ my $comment = $functions->{'comment'};
+ my $functionargs = $functions->{'function_args'};
+ my @types = split( ' ', $functionargs );
+ my $count = 0;
+
+ # Pre-setup argument names when available.
+ my $argnames = $functions->{'function_arg_names'};
+ my @names;
+
+ if ( defined($argnames) ) {
+ $argnames =~ s/{(.*)}/$1/;
+ @names = split( ',', $argnames );
+ }
+
+ # Setup full argument types -- including the name prefix
+ foreach my $type (@types) {
+ $sth_FunctionArg->execute($type);
+
+ my $hash = $sth_FunctionArg->fetchrow_hashref;
+
+ if ( $count > 0 ) {
+ $functionname .= ', ';
+ }
-# Write out *ALL* templates
-&write_using_templates();
+ if ( scalar(@names) > 0 ) {
+ $functionname .= $names[$count] . ' ';
+ }
+
+ if ( $hash->{'namespace'} ne $system_schema ) {
+ $functionname .= $hash->{'namespace'} . '.';
+ }
+ $functionname .= $hash->{'type_name'};
+
+ $count++;
+ }
+ $functionname .= ' )';
+ my $ret_type = $functions->{'returns_set'} ? 'SET OF ' : '';
+ $sth_FunctionArg->execute( $functions->{'return_type'} );
+ my $rhash = $sth_FunctionArg->fetchrow_hashref;
+ $ret_type .= $rhash->{'type_name'};
+
+ $struct->{$schema}{'FUNCTION'}{$functionname}{'COMMENT'} = $comment;
+ $struct->{$schema}{'FUNCTION'}{$functionname}{'SOURCE'} =
+ $functions->{'source_code'};
+ $struct->{$schema}{'FUNCTION'}{$functionname}{'LANGUAGE'} =
+ $functions->{'language_name'};
+ $struct->{$schema}{'FUNCTION'}{$functionname}{'RETURNS'} = $ret_type;
+ }
+
+ # Deal with the Schema
+ $sth_Schema->execute();
+ while ( my $schema = $sth_Schema->fetchrow_hashref ) {
+ my $comment = $schema->{'comment'};
+ my $namespace = $schema->{'namespace'};
+
+ $struct->{$namespace}{'SCHEMA'}{'COMMENT'} = $comment;
+ }
+
+} ## end sub info_collect($$$$$)
#####
# write_using_templates
-# Generate structure that HTML::Template requires out of the
-# $structure for table related information, and $struct for
-# the schema and function information
#
-# TODO: Finish conversion of $structure format into $struct
-sub write_using_templates
+# Generate structure that HTML::Template requires out of the
+# $struct for table related information, and $struct for
+# the schema and function information
+sub write_using_templates($$$$$)
{
- my @schemas;
- # Start at 0, increment to 1 prior to use.
- my $object_id = 0;
- my %tableids;
- foreach my $schema ( sort keys %structure ) {
- my @tables;
- foreach my $table ( sort keys %{ $structure{$schema} } ) {
- # Column List
- my @columns;
- foreach my $column (
- sort {
- $structure{$schema}{$table}{'COLUMN'}{$a}{'ORDER'} <=>
- $structure{$schema}{$table}{'COLUMN'}{$b}{'ORDER'}
- } keys %{ $structure{$schema}{$table}{'COLUMN'} }
- )
- {
- my $inferrednotnull = 0;
-
- # Have a shorter default for places that require it
- my $shortdefault = $structure{$schema}{$table}{'COLUMN'}{$column}{'DEFAULT'};
- $shortdefault =~ s/^(.{17}).{5,}(.{5})$/$1 ... $2/g;
-
- # Deal with column constraints
- my @colconstraints;
- foreach my $con
- ( sort keys %{ $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'} })
- {
- if ($structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'TYPE'} eq 'UNIQUE') {
- my $unq = $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'TYPE'};
- my $unqcol = $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'COLNUM'};
- my $unqgroup = $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'KEYGROUP'};
-
- push @colconstraints, {
- column_unique => $unq,
- column_unique_colnum => $unqcol,
- column_unique_keygroup => $unqgroup,
- };
- } elsif ($structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'TYPE'} eq 'PRIMARY KEY') {
- $inferrednotnull = 1;
- push @colconstraints, {
- column_primary_key => 'PRIMARY KEY',
- };
- } elsif ($structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'TYPE'} eq 'FOREIGN KEY') {
- my $fksgmlid = sgml_safe_id(
- join('.'
- , $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'FKSCHEMA'}
- , $structure{$schema}{$table}{'TYPE'}
- , $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'FKTABLE'}));
-
- my $fkgroup = $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'KEYGROUP'};
- my $fktable = $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'FKTABLE'};
- my $fkcol = $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'FK-COL NAME'};
- my $fkschema = $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'FKSCHEMA'};
-
- push @colconstraints, {
- column_fk => 'FOREIGN KEY',
- column_fk_colnum => $fkcol,
- column_fk_keygroup => $fkgroup,
- column_fk_schema => $fkschema,
- column_fk_schema_dbk => docbook($fkschema),
- column_fk_schema_dot => graphviz($fkschema),
- column_fk_sgmlid => $fksgmlid,
- column_fk_table => $fktable,
- column_fk_table_dbk => docbook($fktable),
- };
-
- # only have the count if there is more than 1 schema
- if (scalar(keys %structure) > 1) {
- $colconstraints[-1]{"number_of_schemas"} = scalar(keys %structure);
- }
- }
- }
-
-
- # Generate the Column array
- push @columns, {
- column => $column,
- column_dbk => docbook($column),
- column_dot => graphviz($column),
- column_default => $structure{$schema}{$table}{'COLUMN'}{$column}{'DEFAULT'},
- column_default_dbk => docbook($structure{$schema}{$table}{'COLUMN'}{$column}{'DEFAULT'}),
- column_default_short => $shortdefault,
- column_default_short_dbk => docbook($shortdefault),
-
- column_comment => $structure{$schema}{$table}{'COLUMN'}{$column}{'DESCRIPTION'},
- column_comment_dbk => docbook($structure{$schema}{$table}{'COLUMN'}{$column}{'DESCRIPTION'}),
-
- column_number => $structure{$schema}{$table}{'COLUMN'}{$column}{'ORDER'},
-
- column_type => $structure{$schema}{$table}{'COLUMN'}{$column}{'TYPE'},
- column_type_dbk => docbook($structure{$schema}{$table}{'COLUMN'}{$column}{'TYPE'}),
-
- column_constraints => \@colconstraints,
- };
-
- if ($inferrednotnull == 0) {
- $columns[-1]{"column_constraint_notnull"} =
- $structure{$schema}{$table}{'COLUMN'}{$column}{'NULL'};
- }
- }
-
- # Constraint List
- my @constraints;
- foreach my $constraint (sort keys %{$structure{$schema}{$table}{'CONSTRAINT'}}) {
- my $shortcon = $structure{$schema}{$table}{'CONSTRAINT'}{$constraint};
- $shortcon =~ s/^(.{30}).{5,}(.{5})$/$1 ... $2/g;
- push @constraints, {
- constraint => $structure{$schema}{$table}{'CONSTRAINT'}{$constraint},
- constraint_dbk => docbook($structure{$schema}{$table}{'CONSTRAINT'}{$constraint}),
- constraint_name => $constraint,
- constraint_name_dbk => docbook($constraint),
- constraint_short => $shortcon,
- constraint_short_dbk => docbook($shortcon),
- table => $table,
- table_dbk => docbook($table),
- table_dot => graphviz($table),
- };
- }
-
- # Index List
- my @indexes;
- foreach my $index (sort keys %{$structure{$schema}{$table}{'INDEX'}}) {
- push @indexes, {
- index_definition => $structure{$schema}{$table}{'INDEX'}{$index},
- index_definition_dbk => docbook($structure{$schema}{$table}{'INDEX'}{$index}),
- index_name => $index,
- index_name_dbk => docbook($index),
- table => $table,
- table_dbk => docbook($table),
- table_dot => graphviz($table),
- schema => $schema,
- schema_dbk => docbook($schema),
- schema_dot => graphviz($schema),
- };
- }
-
- # Foreign Key Discovery
- #
- # $lastmatch is used to ensure that we only supply a result a single time and not once
- # for each link found. Since the loops are sorted, we only need to track the last
- # element, and not all supplied elements.
- my @fk_schemas;
- my $lastmatch = '';
- foreach my $fk_schema ( sort keys %structure ) {
- foreach my $fk_table ( sort keys %{ $structure{$fk_schema} } ) {
- foreach my $fk_column (
- sort keys %{ $structure{$fk_schema}{$fk_table}{'COLUMN'} } )
- {
- foreach my $con (
- sort keys %{$structure{$fk_schema}{$fk_table}{'COLUMN'}{$fk_column}{'CON'}}
- ) {
- if (
- $structure{$fk_schema}{$fk_table}{'COLUMN'}{$fk_column}{'CON'}{$con}{'TYPE'} eq 'FOREIGN KEY'
- && $structure{$fk_schema}{$fk_table}{'COLUMN'}{$fk_column}{'CON'}{$con}{'FKTABLE'} eq $table
- && $structure{$fk_schema}{$fk_table}{'COLUMN'}{$fk_column}{'CON'}{$con}{'FKSCHEMA'} eq $schema
- && $lastmatch ne "$fk_schema$fk_table"
- )
- {
- my $fksgmlid = sgml_safe_id(
- join('.',$fk_schema
- , $structure{$fk_schema}{$fk_table}{'TYPE'}
- , $fk_table));
- push @fk_schemas, {
- fk_column_number => $structure{$fk_schema}{$fk_table}{'COLUMN'}{$fk_column}{'ORDER'},
- fk_sgmlid => $fksgmlid,
- fk_schema => $fk_schema,
- fk_schema_dbk => docbook($fk_schema),
- fk_schema_dot => graphviz($fk_schema),
- fk_table => $fk_table,
- fk_table_dbk => docbook($fk_table),
- fk_table_dot => graphviz($fk_table),
- };
-
- # only have the count if there is more than 1 schema
- if (scalar(keys %structure) > 1) {
- $fk_schemas[-1]{"number_of_schemas"} = scalar(keys %structure);
- }
-
- $lastmatch = "$fk_schema$fk_table";
- }
- }
- }
- }
- }
-
- # List off permissions
- my @permissions;
- foreach my $user ( sort keys %{ $structure{$schema}{$table}{'ACL'} } ) {
- push @permissions, {
- schema => $schema,
- schema_dbk => docbook($schema),
- schema_dot => graphviz($schema),
- table => $table,
- table_dbk => docbook($table),
- table_dot => graphviz($table),
- user => $user,
- user_dbk => docbook($user),
- };
-
- # only have the count if there is more than 1 schema
- if (scalar(keys %structure) > 1) {
- $permissions[-1]{"number_of_schemas"} = scalar(keys %structure);
- }
-
- foreach my $perm ( keys %{ $structure{$schema}{$table}{'ACL'}{$user} } ) {
- if ( $structure{$schema}{$table}{'ACL'}{$user}{$perm} == 1 ) {
- $permissions[-1]{lower($perm)} = 1;
- }
- }
-
- }
-
- # Increment and record the object ID
- $tableids{"$schema$table"} = ++$object_id;
- my $viewdef = sql_prettyprint($structure{$schema}{$table}{'VIEW_DEF'});
-
- # Truncate comment for Dia
- my $comment_dia = $structure{$schema}{$table}{'DESCRIPTION'};
- $comment_dia =~ s/^(.{35}).{5,}(.{5})$/$1 ... $2/g;
-
- push @tables, {
- object_id => $object_id,
- object_id_dbk => docbook($object_id),
-
- schema => $schema,
- schema_dbk => docbook($schema),
- schema_dot => graphviz($schema),
- schema_sgmlid => sgml_safe_id($schema.".schema"),
-
- # Statistics
- stats_enabled => $statistics,
- stats_dead_bytes => useUnits($structure{$schema}{$table}{'DEADTUPLELEN'}),
- stats_dead_bytes_dbk => docbook(useUnits($structure{$schema}{$table}{'DEADTUPLELEN'})),
- stats_free_bytes => useUnits($structure{$schema}{$table}{'FREELEN'}),
- stats_free_bytes_dbk => docbook(useUnits($structure{$schema}{$table}{'FREELEN'})),
- stats_table_bytes => useUnits($structure{$schema}{$table}{'TABLELEN'}),
- stats_table_bytes_dbk => docbook(useUnits($structure{$schema}{$table}{'TABLELEN'})),
- stats_tuple_count => $structure{$schema}{$table}{'TUPLECOUNT'},
- stats_tuple_count_dbk => docbook($structure{$schema}{$table}{'TUPLECOUNT'}),
- stats_tuple_bytes => useUnits($structure{$schema}{$table}{'TUPLELEN'}),
- stats_tuple_bytes_dbk => docbook(useUnits($structure{$schema}{$table}{'TUPLELEN'})),
-
- table => $table,
- table_dbk => docbook($table),
- table_dot => graphviz($table),
- table_sgmlid => sgml_safe_id(join('.', $schema, $structure{$schema}{$table}{'TYPE'}, $table)),
- table_comment => $structure{$schema}{$table}{'DESCRIPTION'},
- table_comment_dbk => docbook($structure{$schema}{$table}{'DESCRIPTION'}),
- table_comment_dia => $comment_dia,
- view_definition => $viewdef,
- view_definition_dbk => docbook($viewdef),
- columns => \@columns,
- constraints => \@constraints,
- fk_schemas => \@fk_schemas,
- indexes => \@indexes,
- permissions => \@permissions,
- };
-
- # only have the count if there is more than 1 schema
- if (scalar(keys %structure) > 1) {
- $tables[-1]{"number_of_schemas"} = scalar(keys %structure);
- }
- }
-
- # Dump out list of functions
- my @functions;
- foreach my $function ( sort keys %{ $struct{'FUNCTION'}{$schema} } ) {
- push @functions, {
- function => $function,
- function_dbk => docbook($function),
- function_sgmlid => sgml_safe_id(join('.', $schema, 'function', $function)),
- function_comment => $struct{'FUNCTION'}{$schema}{$function}{'COMMENT'},
- function_comment_dbk => docbook($struct{'FUNCTION'}{$schema}{$function}{'COMMENT'}),
- function_language => uc($struct{'FUNCTION'}{$schema}{$function}{'LANGUAGE'}),
- function_returns => $struct{'FUNCTION'}{$schema}{$function}{'RETURNS'},
- function_source => $struct{'FUNCTION'}{$schema}{$function}{'SOURCE'},
- schema => $schema,
- schema_dbk => docbook($schema),
- schema_dot => graphviz($schema),
- schema_sgmlid => sgml_safe_id($schema.".schema"),
- };
-
- # only have the count if there is more than 1 schema
- if (scalar(keys %structure) > 1) {
- $functions[-1]{"number_of_schemas"} = scalar(keys %structure);
- }
- }
-
- push @schemas, {
- schema => $schema,
- schema_dbk => docbook($schema),
- schema_dot => graphviz($schema),
- schema_sgmlid => sgml_safe_id($schema.".schema"),
- schema_comment => $struct{'SCHEMA'}{$schema}{'COMMENT'},
- schema_comment_dbk => docbook($struct{'SCHEMA'}{$schema}{'COMMENT'}),
- functions => \@functions,
- tables => \@tables,
- };
-
- # Build the array of schemas
- if (scalar(keys %structure) > 1) {
- $schemas[-1]{"number_of_schemas"} = scalar(keys %structure);
- }
- }
-
- # Link the various components together via the template.
- my @fk_links;
- my @fkeys;
- foreach my $schema ( sort keys %structure ) {
- foreach my $table ( sort keys %{ $structure{$schema} } ) {
- foreach my $column (
- sort {
- $structure{$schema}{$table}{'COLUMN'}{$a}{'ORDER'} <=>
- $structure{$schema}{$table}{'COLUMN'}{$b}{'ORDER'}
- }
- keys %{ $structure{$schema}{$table}{'COLUMN'} }
- ) {
- foreach my $con (
- sort keys %{$structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}}
- ) {
- # To prevent a multi-column foreign key from appearing several times, we've opted
- # to simply display the first column of any given key. Since column numbering
- # always starts at 1 for foreign keys.
- if ( $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'TYPE'}
- eq 'FOREIGN KEY'
- && $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'COLNUM'}
- == 1 )
- {
- # Pull out some of the longer keys
- my $ref_table = $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'FKTABLE'};
- my $ref_schema = $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'FKSCHEMA'};
- my $ref_column = $structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'FK-COL NAME'};
-
- # Default values cause these elements to attach to the bottom in Dia
- #
- # If a KEYGROUP is not defined, it's a single column. Modify the ref_con
- # and key_con variables to attach the to the columns connection point
- # directly.
- my $ref_con = 0;
- my $key_con = 0;
- my $keycon_offset = 0;
- if (!defined($structure{$schema}{$table}{'COLUMN'}{$column}{'CON'}{$con}{'KEYGROUP'})) {
- $ref_con = $structure{$ref_schema}{$ref_table}{'COLUMN'}{$ref_column}{'ORDER'};
- $key_con = $structure{$schema}{$table}{'COLUMN'}{$column}{'ORDER'};
- $keycon_offset = 1;
- }
-
- # Bump object_id
- $object_id++;
-
- push @fk_links, {
- fk_link_name => $con,
- fk_link_name_dbk => docbook($con),
- fk_link_name_dot => graphviz($con),
- handle0_connection => $key_con,
- handle0_connection_dbk => docbook($key_con),
- handle0_connection_dia => 6 + ($key_con * 2),
- handle0_name => $table,
- handle0_name_dbk => docbook($table),
- handle0_schema => $schema,
- handle0_to => $tableids{"$schema$table"},
- handle0_to_dbk => docbook($tableids{"$schema$table"}),
- handle1_connection => $ref_con,
- handle1_connection_dbk => docbook($ref_con),
- handle1_connection_dia => 6 + ($ref_con * 2) + $keycon_offset,
- handle1_name => $ref_table,
- handle1_name_dbk => docbook($ref_table),
- handle1_schema => $ref_schema,
- handle1_to => $tableids{"$ref_schema$ref_table"},
- handle1_to_dbk => docbook($tableids{"$ref_schema$ref_table"}),
- object_id => $object_id,
- object_id_dbk => docbook($object_id),
- };
-
- # Build the array of schemas
- if (scalar(keys %structure) > 1) {
- $fk_links[-1]{"number_of_schemas"} = scalar(keys %structure);
- }
- }
- }
- }
- }
- }
-
-### FOR DEBUGGING ###
-# print Data::Dumper->Dump(\@schemas);
-
- # Make database level comment information
- my @timestamp = localtime();
- my $dumped_on = sprintf("%04d-%02d-%02d", $timestamp[5]+1900, $timestamp[4]+1, $timestamp[3]);
- my $database_comment = $struct{'DATABASE'}{$database}{'COMMENT'};
-
- # Loop through each template found in the supplied path. Output the results of the template
- # as <filename>.<extension> into the current working directory.
- my @template_files = glob($template_path .'/*.tmpl');
-
- # Ensure we've told the user if we don't find any files.
- triggerError("Templates files not found in $template_path")
- if ($#template_files < 0);
-
- # Process all found templates.
- foreach my $template_file (@template_files) {
- (my $file_extension = $template_file) =~ s/^(?:.*\/|)([^\/]+)\.tmpl$/$1/;
- next if (defined($wanted_output) && $file_extension ne $wanted_output);
- my $output_filename = "$output_filename_base.$file_extension";
- print "Producing $output_filename from $template_file\n";
-
- my $template = HTML::Template->new(
- filename => $template_file,
- die_on_bad_params => 0,
- global_vars => 0,
- strict => 1,
- loop_context_vars => 1
- );
-
- $template->param(
- database => $database,
- database_dbk => docbook($database),
- database_sgmlid => sgml_safe_id($database),
- database_comment => $database_comment,
- database_comment_dbk => docbook($database_comment),
- dumped_on => $dumped_on,
- dumped_on_dbk => docbook($dumped_on),
- fk_links => \@fk_links,
- schemas => \@schemas,
- );
-
- sysopen( FH, $output_filename, O_WRONLY | O_TRUNC | O_CREAT, 0644 )
- or die "Can't open $output_filename: $!";
- print FH $template->output();
- }
-}
+ my ( $db, $database, $statistics, $template_path, $output_filename_base,
+ $wanted_output )
+ = @_;
+ my $struct = $db->{$database}{'STRUCT'};
+
+ my @schemas;
+
+ # Start at 0, increment to 1 prior to use.
+ my $object_id = 0;
+ my %tableids;
+ foreach my $schema ( sort keys %{$struct} ) {
+ my @tables;
+ foreach my $table ( sort keys %{ $struct->{$schema}{'TABLE'} } ) {
+
+ # Column List
+ my @columns;
+ foreach my $column (
+ sort {
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$a}
+ {'ORDER'} <=> $struct->{$schema}{'TABLE'}{$table}
+ {'COLUMN'}{$b}{'ORDER'}
+ } keys %{ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'} }
+ )
+ {
+ my $inferrednotnull = 0;
+
+ # Have a shorter default for places that require it
+ my $shortdefault =
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'DEFAULT'};
+ $shortdefault =~ s/^(.{17}).{5,}(.{5})$/$1 ... $2/g
+ if ( defined($shortdefault) );
+
+ # Deal with column constraints
+ my @colconstraints;
+ foreach my $con (
+ sort keys %{
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}
+ }
+ )
+ {
+ if ( $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'TYPE'} eq 'UNIQUE' )
+ {
+ my $unq =
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'TYPE'};
+ my $unqcol =
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'COLNUM'};
+ my $unqgroup =
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'KEYGROUP'};
+
+ push @colconstraints,
+ {
+ column_unique => $unq,
+ column_unique_colnum => $unqcol,
+ column_unique_keygroup => $unqgroup,
+ };
+ }
+ elsif (
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'TYPE'} eq 'PRIMARY KEY' )
+ {
+ $inferrednotnull = 1;
+ push @colconstraints,
+ { column_primary_key => 'PRIMARY KEY', };
+ }
+ elsif (
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'TYPE'} eq 'FOREIGN KEY' )
+ {
+ my $fksgmlid = sgml_safe_id(
+ join( '.',
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}
+ {$column}{'CON'}{$con}{'FKSCHEMA'},
+ $struct->{$schema}{'TABLE'}{$table}{'TYPE'},
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}
+ {$column}{'CON'}{$con}{'FKTABLE'} )
+ );
+
+ my $fkgroup =
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'KEYGROUP'};
+ my $fktable =
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'FKTABLE'};
+ my $fkcol =
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'FK-COL NAME'};
+ my $fkschema =
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'FKSCHEMA'};
+
+ push @colconstraints,
+ {
+ column_fk => 'FOREIGN KEY',
+ column_fk_colnum => $fkcol,
+ column_fk_keygroup => $fkschema,
+ column_fk_schema => $fkschema,
+ column_fk_schema_dbk => docbook($fkschema),
+ column_fk_schema_dot => graphviz($fkschema),
+ column_fk_sgmlid => $fksgmlid,
+ column_fk_table => $fktable,
+ column_fk_table_dbk => docbook($fktable),
+ };
+
+ # only have the count if there is more than 1 schema
+ if ( scalar( keys %{$struct} ) > 1 ) {
+ $colconstraints[-1]{"number_of_schemas"} =
+ scalar( keys %{$struct} );
+ }
+ }
+ }
+
+ # Generate the Column array
+ push @columns, {
+ column => $column,
+ column_dbk => docbook($column),
+ column_dot => graphviz($column),
+ column_default =>
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'DEFAULT'},
+ column_default_dbk => docbook(
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'DEFAULT'}
+ ),
+ column_default_short => $shortdefault,
+ column_default_short_dbk => docbook($shortdefault),
+
+ column_comment =>
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'DESCRIPTION'},
+ column_comment_dbk => docbook(
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'DESCRIPTION'}
+ ),
+
+ column_number =>
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'ORDER'},
+
+ column_type =>
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'TYPE'},
+ column_type_dbk => docbook(
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'TYPE'}
+ ),
+
+ column_constraints => \@colconstraints,
+ };
+
+ if ( $inferrednotnull == 0 ) {
+ $columns[-1]{"column_constraint_notnull"} =
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'NULL'};
+ }
+ }
+
+ # Constraint List
+ my @constraints;
+ foreach my $constraint (
+ sort
+ keys %{ $struct->{$schema}{'TABLE'}{$table}{'CONSTRAINT'} }
+ )
+ {
+ my $shortcon =
+ $struct->{$schema}{'TABLE'}{$table}{'CONSTRAINT'}
+ {$constraint};
+ $shortcon =~ s/^(.{30}).{5,}(.{5})$/$1 ... $2/g;
+ push @constraints,
+ {
+ constraint =>
+ $struct->{$schema}{'TABLE'}{$table}{'CONSTRAINT'}
+ {$constraint},
+ constraint_dbk => docbook(
+ $struct->{$schema}{'TABLE'}{$table}{'CONSTRAINT'}
+ {$constraint}
+ ),
+ constraint_name => $constraint,
+ constraint_name_dbk => docbook($constraint),
+ constraint_short => $shortcon,
+ constraint_short_dbk => docbook($shortcon),
+ table => $table,
+ table_dbk => docbook($table),
+ table_dot => graphviz($table),
+ };
+ }
+
+ # Index List
+ my @indexes;
+ foreach my $index (
+ sort keys %{ $struct->{$schema}{'TABLE'}{$table}{'INDEX'} } )
+ {
+ push @indexes,
+ {
+ index_definition =>
+ $struct->{$schema}{'TABLE'}{$table}{'INDEX'}{$index},
+ index_definition_dbk => docbook(
+ $struct->{$schema}{'TABLE'}{$table}{'INDEX'}{$index}
+ ),
+ index_name => $index,
+ index_name_dbk => docbook($index),
+ table => $table,
+ table_dbk => docbook($table),
+ table_dot => graphviz($table),
+ schema => $schema,
+ schema_dbk => docbook($schema),
+ schema_dot => graphviz($schema),
+ };
+ }
+
+ # Foreign Key Discovery
+ #
+ # $lastmatch is used to ensure that we only supply a result a
+ # single time and not once for each link found. Since the
+ # loops are sorted, we only need to track the last element, and
+ # not all supplied elements.
+ my @fk_schemas;
+ my $lastmatch = '';
+ foreach my $fk_schema ( sort keys %{$struct} ) {
+ foreach
+ my $fk_table ( sort keys %{ $struct->{$fk_schema}{'TABLE'} } )
+ {
+ foreach my $fk_column (
+ sort keys
+ %{ $struct->{$fk_schema}{'TABLE'}{$fk_table}{'COLUMN'} }
+ )
+ {
+ foreach my $fk_con (
+ sort keys %{
+ $struct->{$fk_schema}{'TABLE'}{$fk_table}
+ {'COLUMN'}{$fk_column}{'CON'}
+ }
+ )
+ {
+ if ( $struct->{$fk_schema}{'TABLE'}{$fk_table}
+ {'COLUMN'}{$fk_column}{'CON'}{$fk_con}{'TYPE'}
+ eq 'FOREIGN KEY'
+ and $struct->{$fk_schema}{'TABLE'}{$fk_table}
+ {'COLUMN'}{$fk_column}{'CON'}{$fk_con}
+ {'FKTABLE'} eq $table
+ and $struct->{$fk_schema}{'TABLE'}{$fk_table}
+ {'COLUMN'}{$fk_column}{'CON'}{$fk_con}
+ {'FKSCHEMA'} eq $schema
+ and $lastmatch ne "$fk_schema$fk_table" )
+ {
+ my $fksgmlid = sgml_safe_id(
+ join( '.',
+ $fk_schema,
+ $struct->{$fk_schema}{'TABLE'}
+ {$fk_table}{'TYPE'},
+ $fk_table )
+ );
+ push @fk_schemas,
+ {
+ fk_column_number =>
+ $struct->{$fk_schema}{'TABLE'}{$fk_table}
+ {'COLUMN'}{$fk_column}{'ORDER'},
+ fk_sgmlid => $fksgmlid,
+ fk_schema => $fk_schema,
+ fk_schema_dbk => docbook($fk_schema),
+ fk_schema_dot => graphviz($fk_schema),
+ fk_table => $fk_table,
+ fk_table_dbk => docbook($fk_table),
+ fk_table_dot => graphviz($fk_table),
+ };
+
+ # only have the count if there is more than 1 schema
+ if ( scalar( keys %{$struct} ) > 1 ) {
+ $fk_schemas[-1]{"number_of_schemas"} =
+ scalar( keys %{$struct} );
+ }
+
+ $lastmatch = "$fk_schema$fk_table";
+ }
+ }
+ }
+ }
+ }
+
+ # List off permissions
+ my @permissions;
+ foreach my $user (
+ sort keys %{ $struct->{$schema}{'TABLE'}{$table}{'ACL'} } )
+ {
+ push @permissions,
+ {
+ schema => $schema,
+ schema_dbk => docbook($schema),
+ schema_dot => graphviz($schema),
+ table => $table,
+ table_dbk => docbook($table),
+ table_dot => graphviz($table),
+ user => $user,
+ user_dbk => docbook($user),
+ };
+
+ # only have the count if there is more than 1 schema
+ if ( scalar( keys %{$struct} ) > 1 ) {
+ $permissions[-1]{"number_of_schemas"} =
+ scalar( keys %{$struct} );
+ }
+
+ foreach my $perm (
+ keys %{ $struct->{$schema}{'TABLE'}{$table}{'ACL'}{$user} }
+ )
+ {
+ if ( $struct->{$schema}{'TABLE'}{$table}{'ACL'}{$user}
+ {$perm} == 1 )
+ {
+ $permissions[-1]{ lower($perm) } = 1;
+ }
+ }
+
+ }
+
+ # Increment and record the object ID
+ $tableids{"$schema$table"} = ++$object_id;
+ my $viewdef =
+ sql_prettyprint(
+ $struct->{$schema}{'TABLE'}{$table}{'VIEW_DEF'} );
+
+ # Truncate comment for Dia
+ my $comment_dia =
+ $struct->{$schema}{'TABLE'}{$table}{'DESCRIPTION'};
+ $comment_dia =~ s/^(.{35}).{5,}(.{5})$/$1 ... $2/g
+ if ( defined($comment_dia) );
+
+ push @tables, {
+ object_id => $object_id,
+ object_id_dbk => docbook($object_id),
+
+ schema => $schema,
+ schema_dbk => docbook($schema),
+ schema_dot => graphviz($schema),
+ schema_sgmlid => sgml_safe_id( $schema . ".schema" ),
+
+ # Statistics
+ stats_enabled => $statistics,
+ stats_dead_bytes => useUnits(
+ $struct->{$schema}{'TABLE'}{$table}{'DEADTUPLELEN'}
+ ),
+ stats_dead_bytes_dbk => docbook(
+ useUnits(
+ $struct->{$schema}{'TABLE'}{$table}{'DEADTUPLELEN'}
+ )
+ ),
+ stats_free_bytes =>
+ useUnits( $struct->{$schema}{'TABLE'}{$table}{'FREELEN'} ),
+ stats_free_bytes_dbk => docbook(
+ useUnits( $struct->{$schema}{'TABLE'}{$table}{'FREELEN'} )
+ ),
+ stats_table_bytes =>
+ useUnits( $struct->{$schema}{'TABLE'}{$table}{'TABLELEN'} ),
+ stats_table_bytes_dbk => docbook(
+ useUnits( $struct->{$schema}{'TABLE'}{$table}{'TABLELEN'} )
+ ),
+ stats_tuple_count =>
+ $struct->{$schema}{'TABLE'}{$table}{'TUPLECOUNT'},
+ stats_tuple_count_dbk =>
+ docbook( $struct->{$schema}{'TABLE'}{$table}{'TUPLECOUNT'} ),
+ stats_tuple_bytes =>
+ useUnits( $struct->{$schema}{'TABLE'}{$table}{'TUPLELEN'} ),
+ stats_tuple_bytes_dbk => docbook(
+ useUnits( $struct->{$schema}{'TABLE'}{$table}{'TUPLELEN'} )
+ ),
+
+ table => $table,
+ table_dbk => docbook($table),
+ table_dot => graphviz($table),
+ table_sgmlid => sgml_safe_id(
+ join( '.',
+ $schema, $struct->{$schema}{'TABLE'}{$table}{'TYPE'},
+ $table )
+ ),
+ table_comment =>
+ $struct->{$schema}{'TABLE'}{$table}{'DESCRIPTION'},
+ table_comment_dbk =>
+ docbook( $struct->{$schema}{'TABLE'}{$table}{'DESCRIPTION'} ),
+ table_comment_dia => $comment_dia,
+ view_definition => $viewdef,
+ view_definition_dbk => docbook($viewdef),
+ columns => \@columns,
+ constraints => \@constraints,
+ fk_schemas => \@fk_schemas,
+ indexes => \@indexes,
+ permissions => \@permissions,
+ };
+
+ # only have the count if there is more than 1 schema
+ if ( scalar( keys %{$struct} ) > 1 ) {
+ $tables[-1]{"number_of_schemas"} = scalar( keys %{$struct} );
+ }
+ }
+ # Dump out list of functions
+ my @functions;
+ foreach my $function ( sort keys %{ $struct->{$schema}{'FUNCTION'} } ) {
+ push @functions,
+ {
+ function => $function,
+ function_dbk => docbook($function),
+ function_sgmlid =>
+ sgml_safe_id( join( '.', $schema, 'function', $function ) ),
+ function_comment =>
+ $struct->{$schema}{'FUNCTION'}{$function}{'COMMENT'},
+ function_comment_dbk => docbook(
+ $struct->{$schema}{'FUNCTION'}{$function}{'COMMENT'}
+ ),
+ function_language =>
+ uc( $struct->{$schema}{'FUNCTION'}{$function}{'LANGUAGE'} ),
+ function_returns =>
+ $struct->{$schema}{'FUNCTION'}{$function}{'RETURNS'},
+ function_source =>
+ $struct->{$schema}{'FUNCTION'}{$function}{'SOURCE'},
+ schema => $schema,
+ schema_dbk => docbook($schema),
+ schema_dot => graphviz($schema),
+ schema_sgmlid => sgml_safe_id( $schema . ".schema" ),
+ };
+
+ # only have the count if there is more than 1 schema
+ if ( scalar( keys %{$struct} ) > 1 ) {
+ $functions[-1]{"number_of_schemas"} = scalar( keys %{$struct} );
+ }
+ }
+
+ push @schemas,
+ {
+ schema => $schema,
+ schema_dbk => docbook($schema),
+ schema_dot => graphviz($schema),
+ schema_sgmlid => sgml_safe_id( $schema . ".schema" ),
+ schema_comment => $struct->{$schema}{'SCHEMA'}{'COMMENT'},
+ schema_comment_dbk =>
+ docbook( $struct->{$schema}{'SCHEMA'}{'COMMENT'} ),
+ functions => \@functions,
+ tables => \@tables,
+ };
+
+ # Build the array of schemas
+ if ( scalar( keys %{$struct} ) > 1 ) {
+ $schemas[-1]{"number_of_schemas"} = scalar( keys %{$struct} );
+ }
+ }
+
+ # Link the various components together via the template.
+ my @fk_links;
+ my @fkeys;
+ foreach my $schema ( sort keys %{$struct} ) {
+ foreach my $table ( sort keys %{ $struct->{$schema} } ) {
+ foreach my $column (
+ sort {
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$a}
+ {'ORDER'} <=> $struct->{$schema}{'TABLE'}{$table}
+ {'COLUMN'}{$b}{'ORDER'}
+ }
+ keys %{ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'} }
+ )
+ {
+ foreach my $con (
+ sort keys %{
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}
+ }
+ )
+ {
+
+ # To prevent a multi-column foreign key from appearing
+ # several times, we've opted
+ # to simply display the first column of any given key.
+ # Since column numbering always starts at 1
+ # for foreign keys.
+ if ( $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'TYPE'} eq 'FOREIGN KEY'
+ && $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}
+ {$column}{'CON'}{$con}{'COLNUM'} == 1 )
+ {
+
+ # Pull out some of the longer keys
+ my $ref_table =
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'FKTABLE'};
+ my $ref_schema =
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'FKSCHEMA'};
+ my $ref_column =
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}{$column}
+ {'CON'}{$con}{'FK-COL NAME'};
+
+ # Default values cause these elements to attach
+ # to the bottom in Dia
+ # If a KEYGROUP is not defined, it's a single column.
+ # Modify the ref_con and key_con variables to attach
+ # the to the columns connection point directly.
+ my $ref_con = 0;
+ my $key_con = 0;
+ my $keycon_offset = 0;
+ if (
+ !defined(
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}
+ {$column}{'CON'}{$con}{'KEYGROUP'}
+ )
+ )
+ {
+ $ref_con =
+ $struct->{$ref_schema}{'TABLE'}{$ref_table}
+ {'COLUMN'}{$ref_column}{'ORDER'};
+ $key_con =
+ $struct->{$schema}{'TABLE'}{$table}{'COLUMN'}
+ {$column}{'ORDER'};
+ $keycon_offset = 1;
+ }
+
+ # Bump object_id
+ $object_id++;
+
+ push @fk_links,
+ {
+ fk_link_name => $con,
+ fk_link_name_dbk => docbook($con),
+ fk_link_name_dot => graphviz($con),
+ handle0_connection => $key_con,
+ handle0_connection_dbk => docbook($key_con),
+ handle0_connection_dia => 6 + ( $key_con * 2 ),
+ handle0_name => $table,
+ handle0_name_dbk => docbook($table),
+ handle0_schema => $schema,
+ handle0_to => $tableids{"$schema$table"},
+ handle0_to_dbk =>
+ docbook( $tableids{"$schema$table"} ),
+ handle1_connection => $ref_con,
+ handle1_connection_dbk => docbook($ref_con),
+ handle1_connection_dia => 6 + ( $ref_con * 2 ) +
+ $keycon_offset,
+ handle1_name => $ref_table,
+ handle1_name_dbk => docbook($ref_table),
+ handle1_schema => $ref_schema,
+ handle1_to => $tableids{"$ref_schema$ref_table"},
+ handle1_to_dbk =>
+ docbook( $tableids{"$ref_schema$ref_table"} ),
+ object_id => $object_id,
+ object_id_dbk => docbook($object_id),
+ };
+
+ # Build the array of schemas
+ if ( scalar( keys %{$struct} ) > 1 ) {
+ $fk_links[-1]{"number_of_schemas"} =
+ scalar( keys %{$struct} );
+ }
+ }
+ }
+ }
+ }
+ }
+
+ # Make database level comment information
+ my @timestamp = localtime();
+ my $dumped_on = sprintf( "%04d-%02d-%02d",
+ $timestamp[5] + 1900,
+ $timestamp[4] + 1,
+ $timestamp[3] );
+ my $database_comment = $db->{$database}{'COMMENT'};
+
+ # Loop through each template found in the supplied path.
+ # Output the results of the template as <filename>.<extension>
+ # into the current working directory.
+ my @template_files = glob( $template_path . '/*.tmpl' );
+
+ # Ensure we've told the user if we don't find any files.
+ triggerError("Templates files not found in $template_path")
+ if ( $#template_files < 0 );
+
+ # Process all found templates.
+ foreach my $template_file (@template_files) {
+ ( my $file_extension = $template_file ) =~
+ s/^(?:.*\/|)([^\/]+)\.tmpl$/$1/;
+ next
+ if ( defined($wanted_output) && $file_extension ne $wanted_output );
+ my $output_filename = "$output_filename_base.$file_extension";
+ print "Producing $output_filename from $template_file\n";
+
+ my $template = HTML::Template->new(
+ filename => $template_file,
+ die_on_bad_params => 0,
+ global_vars => 0,
+ strict => 1,
+ loop_context_vars => 1
+ );
+
+ $template->param(
+ database => $database,
+ database_dbk => docbook($database),
+ database_sgmlid => sgml_safe_id($database),
+ database_comment => $database_comment,
+ database_comment_dbk => docbook($database_comment),
+ dumped_on => $dumped_on,
+ dumped_on_dbk => docbook($dumped_on),
+ fk_links => \@fk_links,
+ schemas => \@schemas,
+ );
+
+ sysopen( FH, $output_filename, O_WRONLY | O_TRUNC | O_CREAT, 0644 )
+ or die "Can't open $output_filename: $!";
+ print FH $template->output();
+ }
+} ## end sub write_using_templates($$$$$)
######
# sgml_safe_id
# Safe SGML ID Character replacement
-sub sgml_safe_id($) {
- my $string = shift;
+sub sgml_safe_id($)
+{
+ my $string = shift;
- # Lets use the keyword ARRAY in place of the square brackets
- # to prevent duplicating a non-array equivelent
- $string =~ s/\[\]/ARRAY-/g;
+ # Lets use the keyword ARRAY in place of the square brackets
+ # to prevent duplicating a non-array equivelent
+ $string =~ s/\[\]/ARRAY-/g;
- # Brackets, spaces, commads, underscores are not valid 'id' characters
- # replace with as few -'s as possible.
- $string =~ s/[ "',)(_-]+/-/g;
+ # Brackets, spaces, commads, underscores are not valid 'id' characters
+ # replace with as few -'s as possible.
+ $string =~ s/[ "',)(_-]+/-/g;
- # Don't want a - at the end either. It looks silly.
- $string =~ s/-$//g;
+ # Don't want a - at the end either. It looks silly.
+ $string =~ s/-$//g;
- return ($string);
+ return ($string);
}
#####
# lower
# LowerCase the string
-sub lower($) {
- my $string = shift;
+sub lower($)
+{
+ my $string = shift;
- $string =~ tr/A-Z/a-z/;
+ $string =~ tr/A-Z/a-z/;
- return ($string);
+ return ($string);
}
#####
# useUnits
# Tack on base 2 metric units
-sub useUnits($) {
- my $value = shift;
+sub useUnits($)
+{
+ my ($value) = @_;
- my @units = ('Bytes', 'KiBytes', 'MiBytes', 'GiBytes', 'TiBytes');
- my $loop = 0;
+ return '' if ( !defined($value) );
- while ($value >= 1024)
- {
- $loop++;
+ my @units = ( 'Bytes', 'KiBytes', 'MiBytes', 'GiBytes', 'TiBytes' );
+ my $loop = 0;
- $value = $value / 1024;
- }
+ while ( $value >= 1024 ) {
+ $loop++;
- return(sprintf("%.2f %s", $value, $units[$loop]));
+ $value = $value / 1024;
+ }
+
+ return ( sprintf( "%.2f %s", $value, $units[$loop] ) );
}
#####
# docbook
# Docbook output is special in that we may or may not want to escape
# the characters inside the string depending on a string prefix.
-sub docbook($) {
- my $string = shift;
-
- if ( defined($string) ) {
- if ( $string =~ /^\@DOCBOOK/ ) {
- $string =~ s/^\@DOCBOOK//;
- }
- else {
- $string =~ s/&(?!(amp|lt|gr|apos|quot);)/&/g;
- $string =~ s/</</g;
- $string =~ s/>/>/g;
- $string =~ s/'/'/g;
- $string =~ s/"/"/g;
- }
- }
- else {
- # Return an empty string when all else fails
- $string = '';
- }
-
- return ($string);
+sub docbook($)
+{
+ my $string = shift;
+
+ if ( defined($string) ) {
+ if ( $string =~ /^\@DOCBOOK/ ) {
+ $string =~ s/^\@DOCBOOK//;
+ }
+ else {
+ $string =~ s/&(?!(amp|lt|gr|apos|quot);)/&/g;
+ $string =~ s/</</g;
+ $string =~ s/>/>/g;
+ $string =~ s/'/'/g;
+ $string =~ s/"/"/g;
+ }
+ }
+ else {
+
+ # Return an empty string when all else fails
+ $string = '';
+ }
+
+ return ($string);
}
#####
# graphviz
# GraphViz output requires that special characters (like " and whitespace) must be preceeded
# by a \ when a part of a lable.
-sub graphviz($) {
- my $string = shift;
+sub graphviz($)
+{
+ my $string = shift;
- # Ensure we don't return an least a empty string
- $string = '' if (!defined($string));
+ # Ensure we don't return an least a empty string
+ $string = '' if ( !defined($string) );
- $string =~ s/([\s"'])/\\$1/g;
+ $string =~ s/([\s"'])/\\$1/g;
- return ($string);
+ return ($string);
}
-
#####
# sql_prettyprint
# Clean up SQL into something presentable
sub sql_prettyprint($)
{
- my $string = shift;
-
- # If nothing has been sent in, return an empty string
- if (!defined($string))
- {
- return '';
- }
-
- # Initialize Result string
- my $result = '';
-
- # List of tokens to split on
- my $tok = "SELECT|FROM|WHERE|HAVING|GROUP BY|ORDER BY|OR|AND|LEFT JOIN|RIGHT JOIN".
- "|LEFT OUTER JOIN|LEFT INNER JOIN|INNER JOIN|RIGHT OUTER JOIN|RIGHT INNER JOIN".
- "|JOIN|UNION ALL|UNION|EXCEPT|USING|ON|CAST|[\(\),]";
-
- my $key = 0;
- my $bracket = 0;
- my $depth = 0;
- my $indent = 6;
-
- # XXX: Split is wrong -- match would do
- foreach my $elem (split(/(\"[^\"]*\"|'[^']*'|$tok)/, $string))
- {
- my $format;
-
- # Skip junk tokens
- if ($elem =~ /^[\s]?$/)
- {
- next;
- }
-
- # NOTE: Should we drop leading spaces?
- # $elem =~ s/^\s//;
-
- # Close brackets are special
- # Bring depth in a level
- if ($elem =~ /\)/)
- {
- $depth = $depth - $indent;
- if ($key == 1 or $bracket == 1)
- {
- $format = "%s%s";
- } else
- {
- $format = "%s\n%". $depth ."s";
- }
-
- $key = 0;
- $bracket = 0;
- }
- # Open brackets are special
- # Bump depth out a level
- elsif ($elem =~ /\(/)
- {
- if ($key == 1)
- {
- $format = "%s %s";
- } else
- {
- $format = "%s\n%". $depth ."s";
- }
- $depth = $depth + $indent;
- $bracket = 1;
- $key = 0;
- }
- # Key element
- # Token from our list -- format on left hand side of the equation
- # when appropriate.
- elsif ($elem =~ /$tok/)
- {
- if ($key == 1)
- {
- $format = "%s%s";
- } else
- {
- $format = "%s\n%". $depth ."s";
- }
-
- $key = 1;
- $bracket = 0;
- }
- # Value
- # Format for right hand side of the equation
- else {
- $format = "%s%s";
-
- $key = 0;
- }
-
- # Add the new format string to the result
- $result = sprintf($format, $result, $elem);
- }
-
- return $result;
-}
+ my $string = shift;
+
+ # If nothing has been sent in, return an empty string
+ if ( !defined($string) ) {
+ return '';
+ }
+
+ # Initialize Result string
+ my $result = '';
+
+ # List of tokens to split on
+ my $tok =
+ "SELECT|FROM|WHERE|HAVING|GROUP BY|ORDER BY|OR|AND|LEFT JOIN|RIGHT JOIN"
+ . "|LEFT OUTER JOIN|LEFT INNER JOIN|INNER JOIN|RIGHT OUTER JOIN|RIGHT INNER JOIN"
+ . "|JOIN|UNION ALL|UNION|EXCEPT|USING|ON|CAST|[\(\),]";
+
+ my $key = 0;
+ my $bracket = 0;
+ my $depth = 0;
+ my $indent = 6;
+
+ # XXX: Split is wrong -- match would do
+ foreach my $elem ( split( /(\"[^\"]*\"|'[^']*'|$tok)/, $string ) ) {
+ my $format;
+
+ # Skip junk tokens
+ if ( $elem =~ /^[\s]?$/ ) {
+ next;
+ }
+
+ # NOTE: Should we drop leading spaces?
+ # $elem =~ s/^\s//;
+
+ # Close brackets are special
+ # Bring depth in a level
+ if ( $elem =~ /\)/ ) {
+ $depth = $depth - $indent;
+ if ( $key == 1 or $bracket == 1 ) {
+ $format = "%s%s";
+ }
+ else {
+ $format = "%s\n%" . $depth . "s";
+ }
+
+ $key = 0;
+ $bracket = 0;
+ }
+
+ # Open brackets are special
+ # Bump depth out a level
+ elsif ( $elem =~ /\(/ ) {
+ if ( $key == 1 ) {
+ $format = "%s %s";
+ }
+ else {
+ $format = "%s\n%" . $depth . "s";
+ }
+ $depth = $depth + $indent;
+ $bracket = 1;
+ $key = 0;
+ }
+
+ # Key element
+ # Token from our list -- format on left hand side of the equation
+ # when appropriate.
+ elsif ( $elem =~ /$tok/ ) {
+ if ( $key == 1 ) {
+ $format = "%s%s";
+ }
+ else {
+ $format = "%s\n%" . $depth . "s";
+ }
+
+ $key = 1;
+ $bracket = 0;
+ }
+
+ # Value
+ # Format for right hand side of the equation
+ else {
+ $format = "%s%s";
+
+ $key = 0;
+ }
+
+ # Add the new format string to the result
+ $result = sprintf( $format, $result, $elem );
+ }
+
+ return $result;
+} ## end sub sql_prettyprint($)
##
# triggerError
# Print out a supplied error message and exit the script.
sub triggerError($)
{
- my $error = shift;
+ my ($error) = @_;
+
+ # Test error
+ if ( !defined($error) || $error eq '' ) {
- # Test error
- if (!defined($error) || $error eq '')
- {
- triggerError("triggerError: Unknown error");
- }
- printf("\n\n%s\n", $error);
+ # Suppress prototype checking in call to self
+ &triggerError("triggerError: Unknown error");
+ }
+ printf( "\n\n%s\n", $error );
- exit 2;
+ exit 2;
}
#####
# usage
-# Usage
-sub usage() {
- print <<USAGE
+sub usage($$$)
+{
+ my ( $basename, $database, $dbuser ) = @_;
+ print <<USAGE
Usage:
$basename [options] [dbname [username]]
(average size, free space, disk space used, dead tuple counts, etc.)
This is disk intensive on large databases as all pages must be visited.
USAGE
- ;
- exit 1;
+ ;
+ exit 1;
}
+
+##
+# Kick off execution of main()
+main($ARGV);
+
projects / postgresql-autodoc / commitdiff