#------------------------------------------------------------------------------
#$Author: andrius $
#$Date: 2020-12-22 04:44:09 -0500 (Tue, 22 Dec 2020) $ 
#$Revision: 7142 $
#$URL: svn://saulius-grazulis.lt/restful/tags/v0.15.2/lib/RestfulDB/Schema/DBI.pm $
#------------------------------------------------------------------------------
#*
#  An object to metadata queries for the RestfulDB interface when the
#  metadata is stored in a "live" database. Perl DBI interface is used
#  to read the metadata from all supported database engines.
#**

package RestfulDB::Schema::DBI;
use warnings;
use strict;

use parent 'RestfulDB::Schema';

use DBI;
use File::Basename qw(basename);
use List::MoreUtils qw(uniq);
use List::Util qw(any);
use POSIX qw(strftime);

use Database::ForeignKey;
use RestfulDB::Defaults;
use RestfulDB::Exception;
use RestfulDB::Schema qw( is_history_table );
use RestfulDB::SQL qw(
    is_blob
    is_internal_SQLite_table
    is_numerical
);

use Memoize;
#memoize('is_view');
memoize('get_tables_info');

our $date_re = q/[0-9]{4}-[01][0-9]-[0123][0-9]/;
our $uuid_re = q/[a-f0-9]{8}-(?:[a-f0-9]{4}-){3}[a-f0-9]{12}/;

our $debug_sql = 0;

#=======================================================================
# Constructor and destructor

sub new
{
    my( $class, $options ) = @_;
    my $self = {};
    $self->{db}{content} = { %{$options->{content_db} } };
    $self->{db}{meta} = { %{$options->{meta_db} } }
        if exists $options->{meta_db};

    return bless $self;
}

## @method get_column_type_hash ($db, $table)
# Gets a hash(ref) of column types.
#
# @param db Database object
# @param table table name
# @retval column_sql_types hash or hashref (depending on context) of
#  table column names and their SQL types.
sub get_column_type_hash
{
    my ($db, $db_table) = @_;

    $db->_load_column_types_lengths( $db_table );
    return wantarray ?
        %{$db->{column_types}{$db_table}} :
          $db->{column_types}{$db_table};
}

## @method get_column_lengths ($db, $table)
# Gets a hash(ref) of column lengths:
# * for character strings the limits are given in characters;
# * for integers the limit is the maximum absolute value.
#
# @param db Database object
# @param table table name
# @retval column_lengths hash or hashref (depending on context) of
#  table column names and their column lengths.
sub get_column_lengths
{
    my ($db, $db_table) = @_;

    $db->_load_column_types_lengths( $db_table );
    return wantarray ?
        %{$db->{column_lengths}{$db_table}} :
          $db->{column_lengths}{$db_table};
}

sub _load_column_types_lengths
{
    my( $db, $db_table ) = @_;
    return if exists $db->{column_types}{$db_table} &&
              exists $db->{column_lengths}{$db_table};

    my $dbh = $db->{db}{content}{dbh};
    if( $db->{db}{content}{engine} eq 'SQLite' ) {
        my $sth = $dbh->column_info( undef, undef, undef, undef ) or
            die DBI::errstr;

        while( my $row = $sth->fetchrow_hashref() ) {
            next if is_internal_SQLite_table( $row->{TABLE_NAME} );
            $db->{column_types}{$row->{TABLE_NAME}}{$row->{COLUMN_NAME}} =
                $row->{TYPE_NAME};

            # SQLite3 stores all integers in 8-byte signed integers, thus
            # we don't check their length.
            $db->{column_lengths}{$row->{TABLE_NAME}}{$row->{COLUMN_NAME}} =
                !is_numerical( $row->{TYPE_NAME} ) ? $row->{COLUMN_SIZE} : undef;
        }
    } else {
        my $column_info = $db->get_column_info( $db_table );
        for my $column_name (keys %$column_info) {
            my $row = $column_info->{$column_name};

            $db->{column_types}{$db_table}{$row->{COLUMN_NAME}} =
                $row->{TYPE_NAME};

            # For numerical fields 'length' stands for maximum absolute
            # value.
            next if $db->{db}{content}{engine} ne 'mysql' &&
                    is_numerical( $row->{TYPE_NAME} );

            my $column_size;
            if(      lc $row->{TYPE_NAME} eq 'tinyint' ) {
                $column_size = 2 ** (1 * 8) - 1;
            } elsif( lc $row->{TYPE_NAME} eq 'smallint' ) {
                $column_size = 2 ** (2 * 8) - 1;
            } elsif( lc $row->{TYPE_NAME} eq 'mediumint' ) {
                $column_size = 2 ** (3 * 8) - 1;
            } elsif( lc $row->{TYPE_NAME} eq 'int' ) {
                $column_size = 2 ** (4 * 8) - 1;
            } elsif( !is_numerical( $row->{TYPE_NAME} ) ) {
                # BIGINT is really large, thus there is little need to
                # check it.
                $column_size = $row->{COLUMN_SIZE};
            }

            $db->{column_lengths}{$db_table}{$row->{COLUMN_NAME}} =
                $column_size;
        }
    }

    # Setting up the types for composite foreign key pseudocolumns
    my $foreign_keys = $db->get_foreign_keys( $db_table );
    for my $fk (@$foreign_keys) {
        next if !$fk->is_composite;

        # Preloading types for parent tables
        if( $fk->parent_table ne $db_table ) {
            $db->get_column_type_hash( $fk->parent_table );
        }

        my $id_column = $db->get_id_column( $fk->parent_table );
        $db->{column_types}{$db_table}{$fk->name} =
            $db->{column_types}{$fk->parent_table}{$id_column};
        $db->{column_lengths}{$db_table}{$fk->name} =
            $db->{column_lengths}{$fk->{table_to}}{$id_column};
    }

    if( exists $db->{column_types}{$db_table} ||
        defined $db->{column_types}{$db_table} ) {
        return wantarray ?
            %{$db->{column_types}{$db_table}} :
            $db->{column_types}{$db_table};
    } else {
        return wantarray ? () : {};
    }
}

## @method get_mandatory_columns ($db, $table)
# Returns a list of not-NULL columns of a table
sub get_mandatory_columns
{
    my( $db, $table ) = @_;
    my $column_info = $db->get_column_info( $table );
    return [ grep { !$column_info->{$_}{NULLABLE} }
                  sort keys %$column_info ];
}

## @method get_column_comments ($db, $table)
# Returns a hash of comments for each SQL column.
sub get_column_comments
{
    my( $db, $table ) = @_;

    # Comments cannot be read from SQLite databases
    return {} if $db->{db}{content}{engine} ne 'mysql';

    # Try to read from MySQL information schema
    my $comments;
    eval {
        my $dbh = $db->{db}{content}{dbh};
        my $sql_statement = 'SELECT COLUMN_NAME, COLUMN_COMMENT ' .
                            'FROM information_schema.COLUMNS ' .
                            'WHERE TABLE_SCHEMA = ? ' .
                            'AND   TABLE_NAME = ?';
        print STDERR "$sql_statement\n" if $debug_sql;
        my $sth = $dbh->prepare( $sql_statement ) or
            $db->error( "Preparing of $sql_statement failed: $DBI::errstr" );
        $sth->execute( $db->{db}{content}{DB}, $table ) ||
            $db->error( "Could not get comments for columns of table '$table': " .
                        $DBI::errstr );
        $comments = $sth->fetchall_hashref( 'COLUMN_NAME' );
    };
    if( $@ ) {
        warn $@;
        return {};
    }

    return { map { $_ => $comments->{$_}{COLUMN_COMMENT} }
                     keys %$comments };
}

## @method get_column_properties ($db, $table)
# Returns column properties in a hash. The first key of the hash is
# property name, e.g. 'mimetype', 'cssclass' and so on. The second key
# is the database column name. The value is the column name (in the
# same table) of a column that holds the corresponding value
# (cssclass, mimetype, etc.).
#
# @retval column_properties
# \code{perl}
# $descriptions = {
#   mimetype => {
#       column1 => column1_mimetype_column_name,
#       column2 => column2_mimetype_column_name,
#       column3 => column3_mimetype_column_name,
#   },
#   cssclass => {
#       column1 => column1_cssclass_column_name,
#       column3 => column3_cssclass_column_name,
#   },
#   visualisation =>
#       column1 => 'table',
#       column2 => 'card',
#   },
#   # Possible further extension:
#   description => {
#       column1 => 'fk', # "coltype", aka "kind"
#       column2 => 'id',
#   },
# }
# \endcode
sub get_column_properties
{
    my ($db, $table) = @_;

    if( exists $db->{column_properties}{$table} ) {
        return wantarray ?
            %{$db->{column_properties}{$table}} :
              $db->{column_properties}{$table};
    }

    my $autodetected_ids = {};

    # $table is included in the list of tables in order to robustly
    # deal with nonexistent tables.
    for my $table ($db->get_table_list, $table) {
        $db->{column_properties}{$table} = {
            altname  => {},
            cssclass => {},
            coltype => {},
            display => {},
            filename => {},
            md5 => {},
            mimetype => {},
            measurement_units => {},
            printf_format => {},
            visualisation => {},
            validation_regex => {},
            can_be_suggested => {},
            # TODO: DISCUSS: Other possibilities might be 'sqltype',
            # 'description', 'format' and so on; if these are implemented
            # then functionality of 'get_column_types' and similar
            # functions can probably be merged here (S.G.).
        };

        # Guessing types of the rest of the columns that do not have their
        # types defined explicitly in the metadata tables.
        my $column_sql_types = $db->get_column_type_hash( $table );

        foreach (keys %$column_sql_types) {
            if( $_ eq $RestfulDB::Defaults::default_id_column ) {
                $db->{column_properties}{$table}{coltype}{$_} = 'id';
                $autodetected_ids->{$table}{$_} = 1;
            } elsif( /^url|uuid$/ ) {
                $db->{column_properties}{$table}{coltype}{$_} = $_;
            } elsif( /url$/ ) {
                $db->{column_properties}{$table}{coltype}{$_} = 'url';
            } elsif( /revision_id$/ ) {
                $db->{column_properties}{$table}{coltype}{$_} = 'dbrev';
            }

            if( lc $column_sql_types->{$_} eq 'date' ) {
                my $date_re_now = $date_re;
                if( $db->{db}{content}{engine} ne 'mysql' ) {
                    # SQLite databases are much more relaxed about dates,
                    # thus time should also be allowed
                    $date_re_now .= '([ Tt][012][0-9](:[0-5][0-9]){2})?';
                }
                $db->{column_properties}{$table}{validation_regex}{$_} =
                    $date_re_now;
            }
        }

        # Marking foreign key (pseudo)columns as 'fk'.
        my $foreign_keys = $db->get_foreign_keys( $table );
        for my $fk (@$foreign_keys) {
            next if exists $db->{column_properties}{$table}{coltype}{$fk->name};
            $db->{column_properties}{$table}{coltype}{$fk->name} = 'fk';
        }
    }

    # FIXME: this database query should be optimised away by merging it
    # with the corresponding query in get_column_formats() and/or
    # get_foreign_keys methods (S.G.):
    if( $db->{db}{meta} && $db->{db}{meta}{dbh} ) {
        my $dbh = $db->{db}{meta}{dbh};
        my $has_regexes = any { $_ eq 'validation_regex' }
                              Database::_get_table_list( $dbh );
        my $has_numbers = any { $_ eq 'numbers' }
                              Database::_get_table_list( $dbh );
        my $has_units   = any { $_ eq 'measurement_unit' }
                              Database::_get_table_list( $dbh );

        my $sql_statement = 'SELECT d1.*, d2.dbcolumn AS target, ' .
                            'altname.id, altname.altname AS altname' .
                            ($has_regexes ? ', VR.regex AS regex' : '') .
                            ($has_numbers ? ', numbers.id AS numbers_id' : '') .
                            ($has_units   ? ', measurement_unit.symbol AS units' : '') .
                            ' FROM description AS d1 ' .
                            'LEFT JOIN description AS d2 ' .
                            '    ON d1.fk_target = d2.id ' .
                            'LEFT JOIN altname ' .
                            '    ON d1.id = altname.column_id ' .
                            ($has_regexes ?
                            'LEFT JOIN validation_regex AS VR ' .
                            '    ON d1.validation_regex_id = VR.id ' : '') .
                            ($has_numbers ?
                            'LEFT JOIN numbers ' .
                            '    ON d1.id = numbers.column_id ' : '') .
                            ($has_units ?
                            'LEFT JOIN measurement_unit ' .
                            '    ON d1.measurement_unit_id = measurement_unit.id ' : '') .
                            'WHERE d1.dbname = ? ';
        my @dbnames = ( $db->{db}{content}{DB} );
        if( $db->{db}{content}{engine} ne 'mysql' ) {
            $sql_statement .= ' OR d1.dbname = ? ';
            push @dbnames, basename $db->{db}{content}{DB};
        }
        $sql_statement .= 'GROUP BY d1.id ' .
                          'HAVING altname.id = MIN(altname.id) ' .
                          '    OR altname.id IS NULL';

        print STDERR "$sql_statement\n" if $debug_sql;
        my $sth = $dbh->prepare( $sql_statement ) or
            $db->error( "could not prepare SELECT statement: $DBI::errstr" );
        
        $sth->execute( @dbnames ) or
            $db->error( "'SELECT *' failed: " . $DBI::errstr );

        while( my $row = $sth->fetchrow_hashref ) {
            my( $dbtable, $dbcolumn, $coltype, $display, $visualisation,
                $target, $altname, $regex, $numbers_id, $units,
                $printf_format ) =
                ( $row->{dbtable},
                  $row->{dbcolumn},
                  $row->{coltype},
                  $row->{display},
                  $row->{visualisation},
                  $row->{target},
                  $row->{altname},
                  $row->{regex},
                  $row->{numbers_id},
                  $row->{units},
                  $row->{printf_format} );

            # Unsetting all automatically detected id columns
            delete $autodetected_ids->{$dbtable}{$dbcolumn} if $coltype;
            if( $coltype && $coltype eq 'id' ) {
                foreach (keys %{$autodetected_ids->{$dbtable}}) {
                    $db->{column_properties}{$dbtable}{coltype}{$_} = undef;
                    delete $autodetected_ids->{$dbtable}{$dbcolumn};
                }
            }

            my $column_properties = $db->{column_properties}{$dbtable};

            # Column type 'data' is only used to suppress the guesswork
            if( $coltype && $coltype eq 'data' ) {
                $column_properties->{coltype}{$dbcolumn} = undef;
            }

            $column_properties->{coltype}{$dbcolumn} = $coltype if $coltype;
            $column_properties->{display}{$dbcolumn} = $display if $display;
            $column_properties->{altname}{$dbcolumn} = $altname if $altname;
            $column_properties->{measurement_units}{$dbcolumn} = $units if $units;
            $column_properties->{printf_format}{$dbcolumn} = $printf_format
                if $printf_format;
            $regex = $uuid_re if $coltype && $coltype eq 'uuid' && !$regex;
            $column_properties->{validation_regex}{$dbcolumn} = $regex if $regex;

            if( defined $numbers_id ) {
                $column_properties->{can_be_suggested}{$dbcolumn} = 1;
            }

            next if !defined $target;
            $column_properties->{$coltype}{$target} = $dbcolumn;
            $column_properties->{visualisation}{$dbcolumn} = $visualisation;
        }
    }

    return wantarray ?
        %{$db->{column_properties}{$table}} :
          $db->{column_properties}{$table};
}

## @method get_column_formats ($db, $table)
# Returns column formats ('png', 'jpeg', 'xml', 'cif', 'json', 'jmol-cif',
# 'jmol-sdf') from metadata tables. If metadata database is not found,
# only 'blob' types are recognised and returned for further inspection,
# for example, using MIME type.
#
# @retval formats
# \code{perl}
# $formats = {
#   'column' => 'format',
#   ...
# }
# \endcode
sub get_column_formats
{
    my ($db, $table) = @_;

    my %formats;
    if( $db->{db}{meta} && $db->{db}{meta}{dbh} ) {
        # selects from the metadata tables

        my $dbh = $db->{db}{meta}{dbh};
        my @dbnames = ( $db->{db}{content}{DB} );
        my $sql_statement = 'SELECT D.dbcolumn, F.format ' .
                            'FROM description AS D JOIN format AS F ' .
                            'ON D.id = F.column_id ' .
                            'WHERE ( D.dbname = ? ';
        if( $db->{db}{content}{engine} ne 'mysql' ) {
            $sql_statement .= 'OR D.dbname = ? ';
            push @dbnames, basename $db->{db}{content}{DB};
        }
        $sql_statement .= ') AND D.dbtable = ? ' .
                          'AND (F.is_primary IS NULL OR ' .
                          '     F.is_primary = 1)';
        print STDERR "$sql_statement\n" if $debug_sql;
        my $sth = $dbh->prepare( $sql_statement ) or
            $db->error( "Preparing of $sql_statement failed: $DBI::errstr" );
        $sth->execute( @dbnames, $table ) or
            $db->error( "'SELECT *' failed: " . $DBI::errstr );

        while( my @row = $sth->fetchrow_array() ) {
            $formats{$row[0]} = $row[1];
        }
    }

    # Guessing formats of the rest of the columns that do not have their
    # formats defined explicitly in the metadata tables.
    my $column_sql_types = $db->get_column_type_hash( $table );

    for my $column (keys %$column_sql_types) {
        next if exists $formats{$column};
        next unless is_blob($column_sql_types->{$column});
        $formats{$column} = $column_sql_types->{$column};
    }

    return \%formats;
}

## @method get_unique_columns ($db, $table)
# Returns a list of unique columns in a table
sub get_unique_columns
{
    my( $db, $table ) = @_;

    my $dbh = $db->{db}{content}{dbh};

    if( $db->{db}{content}{engine} eq 'mysql' ) {
        my $delim = $db->{db}{content}{delim};
        my $sql_statement = "SHOW INDEX FROM ${delim}${table}${delim} " .
                            'WHERE Non_unique = 0';
        print STDERR "$sql_statement\n" if $debug_sql;
        my $sth = $dbh->prepare( $sql_statement ) or
            $db->error( "could not prepare SELECT statement: $DBI::errstr" );

        $sth->execute or $db->error( "'SELECT *' failed: " . $DBI::errstr );

        my $columns = {};
        while( my $row = $sth->fetchrow_hashref ) {
            push @{$columns->{$row->{Key_name}}}, $row->{Column_name};
        }

        return sort map { $columns->{$_}[0] }
                    grep { scalar @{$columns->{$_}} == 1 }
                         keys %$columns;
    } else {
        # FIXME: this method of unique column determination is unstable as
        # statistics_info() is experimental and is subject of change.
        # Moreover, it did not exist prior to DBD::mysql v4.046.
        my $sth = $dbh->statistics_info( undef, undef, $table, undef, 1 )
            or die DBI::errstr;

        my $unique_columns = $sth->fetchall_hashref( 'COLUMN_NAME' );
        my $seen_indexes = {};
        for my $column_name (keys %$unique_columns) {
            my $column = $unique_columns->{$column_name};
            next if $column->{NON_UNIQUE};
            push @{$seen_indexes->{$column->{INDEX_NAME}}}, $column_name;
        }
        for my $index (keys %$seen_indexes) {
            next if @{$seen_indexes->{$index}} == 1;
            for my $column (@{$seen_indexes->{$index}}) {
                delete $unique_columns->{$column};
            }
        }
        my @unique_columns = grep { $unique_columns->{$_}{NON_UNIQUE} == 0 }
                                  keys %$unique_columns;

        # SQLite driver does not hold PRIMARY KEY as an index (see for example
        # https://stackoverflow.com/questions/3379292/is-an-index-needed-for-a-primary-key-in-sqlite),
        # thus such columns have to be added separately.
        if( $db->{db}{content}{engine} eq 'SQLite' ) {
            my $primary_key_info = $dbh->primary_key_info( undef, undef, $table );
            while( my $key = $primary_key_info->fetchrow_hashref ) {
                next if grep { $_ eq $key->{COLUMN_NAME} } @unique_columns;
                push @unique_columns, $key->{COLUMN_NAME};
            }
        }
        return sort @unique_columns;
    }
}

## @method get_foreign_keys ($db, $table)
# Returns an array of Database::ForeignKey objects representing foreign keys
# of the table in question.
sub get_foreign_keys
{
    my ($db, $table) = @_;

    $db->_load_foreign_keys();
    return exists $db->{fk}{$table} ? $db->{fk}{$table} : [];
}

sub _load_foreign_keys
{
    my( $db ) = @_;
    return if exists $db->{fk};

    my $foreign_keys = {};
    my $columns_seen = {};
    if( $db->{db}{meta} && $db->{db}{meta}{dbh} ) {
        my $dbh = $db->{db}{meta}{dbh};
        my $delim = $db->{db}{meta}{delim};
        my @dbnames = ( $db->{db}{content}{DB} );
        my $sql_statement = 'SELECT ' .
                            "D1.dbcolumn AS ${delim}column_from${delim}, " .
                            "D1.dbtable AS ${delim}table_from${delim}, " .
                            "D1.relation AS ${delim}relation${delim}, " .
                            "D1.visualisation AS ${delim}visualisation${delim}, " .
                            "D2.dbcolumn AS ${delim}column_to${delim}, " .
                            "D2.dbtable AS ${delim}table_to${delim} " .
                            'FROM description AS D1 ' .
                            'JOIN description AS D2 ' .
                            'ON D1.fk_target = D2.id ' .
                            'WHERE ( D1.dbname = ? ';
        if( $db->{db}{content}{engine} ne 'mysql' ) {
            $sql_statement .= 'OR D1.dbname = ? ';
            push @dbnames, basename $db->{db}{content}{DB};
        }
        $sql_statement .= ') AND D1.coltype IN ("fk", "dbrev")';
        print STDERR "$sql_statement\n" if $debug_sql;
        my $sth = $dbh->prepare( $sql_statement ) or
            $db->error( "could not prepare SELECT statement: $DBI::errstr" );

        my $rv = $sth->execute( @dbnames );
        if( defined $rv ) {
            while( my $row = $sth->fetchrow_hashref ) {
                if( !$row->{visualisation} &&
                    $db->is_view( $row->{table_from} ) ) {
                    $row->{visualisation} = 'none';
                }
                push @{$foreign_keys->{$row->{table_from}}},
                     Database::ForeignKey->new(
                         {
                            table_from    => $row->{table_from},
                            table_to      => $row->{table_to},
                            column_from   => [ $row->{column_from} ],
                            column_to     => [ $row->{column_to} ],
                            name          => $row->{column_from},
                            relation      => $row->{relation},
                            visualisation => $row->{visualisation},
                         } );
                $columns_seen->{$row->{table_from}}
                               {$row->{column_from}} = 1;
            }
        } else {
            warn "'SELECT *' failed: " . $DBI::errstr;
        }
    }

    my $dbh = $db->{db}{content}{dbh};
    my $sth;
    if( $db->{db}{content}{engine} eq 'mysql' ) {
        # $sth = $dbh->foreign_key_info( undef, $db->{db}{content}{DB}, undef,
        #                                undef, $db->{db}{content}{DB}, undef );
        my $sql = qq(   SELECT NULL AS PKTABLE_CAT,
                REFERENCED_TABLE_SCHEMA AS PKTABLE_SCHEM,
                REFERENCED_TABLE_NAME AS PKTABLE_NAME,
                REFERENCED_COLUMN_NAME AS PKCOLUMN_NAME,
                TABLE_CATALOG AS FKTABLE_CAT, 
                TABLE_SCHEMA AS FKTABLE_SCHEM,
                TABLE_NAME AS FKTABLE_NAME,
                COLUMN_NAME AS FKCOLUMN_NAME,
                ORDINAL_POSITION AS KEY_SEQ,
                NULL AS UPDATE_RULE,
                NULL AS DELETE_RULE,
                CONSTRAINT_NAME AS FK_NAME,
                NULL AS PK_NAME,NULL AS DEFERABILITY,
                NULL AS UNIQUE_OR_PRIMARY
                from information_schema.key_column_usage 
                where referenced_table_name is not null 
                  and table_schema = ?);

        $sth = $dbh->prepare( $sql )  or
            $db->error( "could not prepare SELECT statement: $DBI::errstr" );

        $sth->execute( $db->{db}{content}{DB} );# or die "execution failed: $dbh->errstr()";
    
        } else {
        $sth = $dbh->foreign_key_info( undef, 'main', undef,
                                       undef, 'main', undef );
    }

    my @column_info;
    while( my $row = $sth->fetchrow_hashref ) {
        # For MySQL foreign_key_info() returns unique keys too
        next if !defined $row->{PKTABLE_NAME};
        push @column_info, $row;
    }

    my @groups = $db->_group_composite_keys( @column_info );

    my @tables = $db->get_table_list();
    my %columns_by_table =
        map { $_ => [ $db->get_column_names( $_, { skip_fk_pseudocolumns => 1,
                                                   display => 'all' } ) ] }
            @tables;
    for my $group (@groups) {
        my $fk = $group->[0];
        if( !grep { $_ eq $fk->{PKTABLE_NAME} } @tables ) {
            die "Table '$fk->{PKTABLE_NAME}' is referred in a foreign key " .
                "in table '$fk->{FKTABLE_NAME}', however, the database " .
                "does not have a table '$fk->{PKTABLE_NAME}'";
        }

        next if @$group == 1 &&
                $columns_seen->{$fk->{FKTABLE_NAME}}{$fk->{FKCOLUMN_NAME}};

        my $name = @$group == 1 ? $fk->{FKCOLUMN_NAME}
                                : defined $fk->{FK_NAME} ? $fk->{FK_NAME}
                                                         : $fk->{PKTABLE_NAME};

        if( grep { $_->{name} eq $name } @{$foreign_keys->{$fk->{FKTABLE_NAME}}} ) {
            warn "Foreign key '$name' in table '$fk->{FKTABLE_NAME}' clashes with " .
                 "a column of the same name, skipping";
            next;
        }

        push @{$foreign_keys->{$fk->{FKTABLE_NAME}}},
             Database::ForeignKey->new(
                 {
                    table_from    => $fk->{FKTABLE_NAME},
                    table_to      => $fk->{PKTABLE_NAME},
                    column_from   => [ map { $_->{FKCOLUMN_NAME} } @$group ],
                    column_to     => [ map { $_->{PKCOLUMN_NAME} } @$group ],
                    name          => $name,
                    visualisation => $db->is_view( $fk->{FKTABLE_NAME} )
                                        ? 'none' : undef,
                 } );
        $columns_seen->{$fk->{FKTABLE_NAME}}
                       {$fk->{FKCOLUMN_NAME}} = 1 if @$group == 1;
    }

    for my $table (@tables) {
        # Guessing foreign keys of the rest of the columns that do not
        # have their defined explicitly in the metadata tables. Columns
        # like '<table>_id' are recognised as foreign keys only if
        # <table> exists.
        for my $column (@{$columns_by_table{$table}}) {
            next if $columns_seen->{$table}{$column};
            if( $column =~ /^(.*)_(id)$/ &&
                grep { $_ eq 'id' } @{$columns_by_table{$1}} ) {
                push @{$foreign_keys->{$table}},
                     Database::ForeignKey->new(
                         {
                            table_from    => $table,
                            table_to      => $1,
                            column_from   => [ $column ],
                            column_to     => [ $2 ],
                            name          => $column,
                            visualisation => $db->is_view( $table )
                                                ? 'none' : undef,
                         } );
            }
        }
    }

    $db->{fk} = $foreign_keys;
}

## @method _group_composite_keys ($db, @keys)
# DBD-specific method to group composite keys.
sub _group_composite_keys
{
    my( $db, @keys ) = @_;
    my @groups;
    if( $db->{db}{content}{engine} eq 'mysql' ) {
        my $fk_by_name = {};
        for my $fk (@keys) {
            push @{$fk_by_name->{$fk->{FKTABLE_NAME}}{$fk->{FK_NAME}}}, $fk;
        }
        for my $table (sort keys %$fk_by_name) {
            for my $fk_name (sort keys %{$fk_by_name->{$table}}) {
                push @groups, [ sort { $a->{KEY_SEQ} <=> $b->{KEY_SEQ} }
                                     @{$fk_by_name->{$table}{$fk_name}} ];
            }
        }
    } else {
        # SQLite foreign keys might not have names, but they are listed
        # in deterministic order by foreign_key_info()
        while( @keys ) {
            my $fk = $keys[-1];
            push @groups, [ splice @keys, -$fk->{KEY_SEQ} ];
        }
    }
    return @groups;
}

sub get_fk_format
{
    my( $db, $table ) = @_;
    return if !$db->{db}{meta}{dbh};
    return $db->{fk_formats}{$table} if exists $db->{fk_formats};

    if( !grep { $_ eq 'fk_format' }
              Database::_get_table_list( $db->{db}{meta}{dbh} ) ) {
        $db->{fk_formats} = {};
        return;
    }

    my $dbh = $db->{db}{meta}{dbh};
    my $delim = $db->{db}{meta}{delim};
    my $sql_statement = 'SELECT * FROM fk_format WHERE dbname = ?';
    my @dbnames = ( $db->{db}{content}{DB} );
    if( $db->{db}{content}{engine} ne 'mysql' ) {
        $sql_statement .= ' OR dbname = ?';
        push @dbnames, basename $db->{db}{content}{DB};
    }
    print STDERR "$sql_statement\n" if $debug_sql;
    my $sth = $dbh->prepare( $sql_statement ) or
        $db->error( "could not prepare SELECT statement: $DBI::errstr" );
    $sth->execute( @dbnames ) or
        $db->error( "Execution of $sql_statement failed: $DBI::errstr" );
    while( my $row = $sth->fetchrow_hashref ) {
        $db->{fk_formats}{$row->{dbtable}} = $row->{format};
    }
    return $db->{fk_formats}{$table};
}

sub get_table_properties
{
    my( $db, $table ) = @_;

    if( exists $db->{table_properties}{$table} ) {
        return wantarray ?
            %{$db->{table_properties}{$table}} :
              $db->{table_properties}{$table};
    }

    for ($db->get_table_list) {
        # By default views are read-only
        $db->{table_properties}{$_}{is_read_only} =
            $db->is_view( $_ );
    }

    if( $db->{db}{meta} && $db->{db}{meta}{dbh} &&
        any { $_ eq 'table_description' }
            Database::_get_table_list( $db->{db}{meta}{dbh} ) ) {
        my $delim = $db->{db}{meta}{delim};
        my $sql_statement = "SELECT * FROM ${delim}table_description${delim} " .
                            'WHERE dbname = ?';
        my @dbnames = ( $db->{db}{content}{DB} );
        if( $db->{db}{content}{engine} ne 'mysql' ) {
            $sql_statement .= ' OR dbname = ?';
            push @dbnames, basename $db->{db}{content}{DB};
        }
        print STDERR "$sql_statement\n" if $debug_sql;
        my $dbh = $db->{db}{meta}{dbh};
        my $sth = $dbh->prepare( $sql_statement ) or
            $db->error( "could not prepare SELECT statement: $DBI::errstr" );
        $sth->execute( @dbnames ) or
            $db->error( "Execution of $sql_statement failed: $DBI::errstr" );

        while( my $row = $sth->fetchrow_hashref ) {
            my( $dbtable, $is_read_only ) =
                ( $row->{dbtable}, $row->{is_read_only} );

            next unless defined $is_read_only;
            $db->{table_properties}{$dbtable}{is_read_only} = $is_read_only;
        }
    }

    return wantarray ?
        %{$db->{table_properties}{$table}} :
          $db->{table_properties}{$table};
}

sub get_grants
{
    my( $db ) = @_;

    return %{$db->{grants}} if exists $db->{grants};

    if( $db->{db}{content}{engine} ne 'mysql' ) {
        $db->{grants} =
            { map { ( $_ => [ 'SELECT', 'INSERT', 'UPDATE', 'DELETE' ] ) }
                  $db->get_table_list };
        return %{$db->{grants}};
    }

    my $sql_statement = 'SHOW GRANTS FOR CURRENT_USER';
    print STDERR "$sql_statement\n" if $debug_sql;
    my $sth = $db->{db}{content}{dbh}->prepare( $sql_statement ) or
        $db->error( "could not prepare statement: $DBI::errstr" );
    $sth->execute or $db->error( "Execution of $sql_statement failed: $DBI::errstr" );

    $db->{grants} = {};
    while( ( $_ ) = $sth->fetchrow_array ) {
        next if !/on\s+(?:table\s+)?(\*|[^\.]+|`[^`]+`)(?:\.(\*|\S+))?/i;
        my( $database, $table ) = ( $1, $2 );
        if( !defined $table ) {
            next if $database ne '*'; # unknown syntax
            $table = '*';
        }
        if( $database ne '*' ) {
            $database =~ s/^`//;
            $database =~ s/`$//;
            next if $database ne $db->{db}{content}{DB};
        }
        my @privileges;
        if( /^grant\s+all\s+(privileges\s+)?on/i ) {
            @privileges = qw( SELECT INSERT UPDATE DELETE );
        } elsif( /^grant\s+(\S+(\s*,\s*\S+)*)\s+on\s+/i ) {
            @privileges = map { uc }
                          grep { /(select|insert|update|delete)/i }
                          split /\s*,\s*/, $1;
        }
        next if !@privileges;
        if( $table eq '*' ) {
            $db->{grants} = { map { ( $_ => \@privileges ) } $db->get_table_list };
        } else {
            $table =~ s/^`//;
            $table =~ s/`$//;
            $db->{grants}{$table} = \@privileges;
        }
    }

    return %{$db->{grants}};
}

sub get_resolvers
{
    my( $db, $table ) = @_;
    return if !$db->{db}{meta}{dbh};
    return $db->{resolvers}{$table} if exists $db->{resolvers};

    my @table_list = Database::_get_table_list( $db->{db}{meta}{dbh} );
    if( (!grep { $_ eq 'resolver' } @table_list) ||
        (!grep { $_ eq 'suffix' } @table_list) ) {
        $db->{resolvers} = {};
        return;
    }

    my $dbh = $db->{db}{meta}{dbh};
    my $delim = $db->{db}{meta}{delim};
    my @dbnames = ( $db->{db}{content}{DB} );
    my $sql_statement = 'SELECT * FROM description ' .
                        'JOIN resolver ON description.id = resolver.column_id ' .
                        'LEFT JOIN suffix ON resolver.id = resolver_id ' .
                        'WHERE ( dbname = ? ';
    if( $db->{db}{content}{engine} ne 'mysql' ) {
        $sql_statement .= ' OR dbname = ? ';
        push @dbnames, basename $db->{db}{content}{DB};
    }
    $sql_statement .= ') AND (resolver.is_primary = 1) AND ' .
                      '(suffix.is_primary IS NULL OR suffix.is_primary = 1)';
    print STDERR "$sql_statement\n" if $debug_sql;
    my $sth = $dbh->prepare( $sql_statement ) or
        $db->error( "could not prepare SELECT statement: $DBI::errstr" );
    $sth->execute( @dbnames ) or
        $db->error( "Execution of $sql_statement failed: $DBI::errstr" );
    while( my $row = $sth->fetchrow_hashref ) {
        $row->{baseurl} =~ s/%/%%/g;
        $row->{suffix}  =~ s/%/%%/g if $row->{suffix};
        $db->{resolvers}{$row->{dbtable}}{$row->{dbcolumn}} =
            $row->{baseurl} . '%s' . ($row->{suffix} ? $row->{suffix} : '');
    }
    return $db->{resolvers}{$table};
}

## @method get_table_list ($db)
# Returns a list of tables in the database.
#
# @param db Database object
# @retval tables array of table names
sub get_table_list
{
    my ($db, $options) = @_;

    $options = {} unless $options;

    my @tables = Database::_get_table_list( $db->{db}{content}{dbh} );
    if( $db->{db}{content}{engine} eq 'SQLite' ) {
        @tables = grep { !is_internal_SQLite_table( $_ ) } @tables;
    }
    if( $options->{skip_history_tables} ) {
        @tables = grep { !is_history_table( $_ ) } @tables;
    }

    return @tables;
}

sub get_column_list
{
    my( $db, $table ) = @_;

    my $column_info = $db->get_column_info( $table, 1 );
    return map { $_->{COLUMN_NAME} } @$column_info;
}

## @method get_table_info ($db,$table_pattern)
#
# Get DBI info for tables specified by the $table_pattern.
#
# @retval $table_info -- DBI table info structure.

sub get_table_info
{
    my ($db,$table_pattern) = @_;

    my $table_info;

    # So far, not caching the result since patterns might be different
    # for the same table.
    my $dbh = $db->{db}{content}{dbh};
    my $tables_sth = $dbh->table_info( undef, undef, $table_pattern, undef ) or
        die DBI::errstr;

    while( my $row = $tables_sth->fetchrow_arrayref ) {
        push @$table_info, $row;
    }

    $tables_sth->finish;

    return $table_info;
}

## @method get_tables_info ( $db )
#
# Get DBI info for tables specified by the $table_pattern.
#
# @retval \%table_info -- hash of the DBI table types 
#                         { table_name => table_type, ...}.

sub get_tables_info
{
    my ( $db ) = @_;

    my $dbh = $db->{db}{content}{dbh};
    my $tables_sth;
    
    if( $db->{db}{content}{engine} eq 'SQLite' ) {
        $tables_sth = $dbh->table_info( undef, 'main', undef, undef ) or
            die DBI::errstr;
    }else{
        $tables_sth = $dbh->table_info( undef, $db->{db}{content}{DB}, undef, undef ) or
            die DBI::errstr;
    }

    my $table;
    my $value;
    my %tables_info;

    $tables_sth->bind_col(3, \$table);
    $tables_sth->bind_col(4, \$value);
    while( my $row = $tables_sth->fetchrow_arrayref ) {
        $tables_info{$table} = $value;
    }

    $tables_sth->finish;

    return \%tables_info;
}

## @method get_column_info ($db, $table)
# Get information hashes for each of the columns in a database.
# The output of this method is highly sensitive to the engine of the
# database.
#
# @param db Database object
# @param table table name
# @retval hash of hashes with information of table's columns
sub get_column_info
{
    my ($db, $table, $raw) = @_;
    if( !exists $db->{column_info}{$table} ) {
        my $dbh = $db->{db}{content}{dbh};
        my $sth = $dbh->column_info( undef, undef, $table, undef ) or
            die DBI::errstr;
        $db->{column_info}{$table} = [];
        while (my $row = $sth->fetchrow_hashref() ) {
            push @{$db->{column_info}{$table}}, $row;
        }
    }

    if( $raw ) {
        return $db->{column_info}{$table} if $raw;
    } else {
        return { map { $_->{COLUMN_NAME} => $_ } @{$db->{column_info}{$table}} };
    }
}

## @method get_value_suggestions ($db, $table, $column)
# Returns value suggestion options for a column.
#
# @param db Database object
# @param table table name
# @param column column name
# @retval array of options (can be empty)
sub get_value_suggestions
{
    my ( $db, $table, $column ) = @_;

    my $dbh = $db->{db}{meta}{dbh};
    my $delim = $db->{db}{meta}{delim};
    my @dbnames = ( $db->{db}{content}{DB} );
    my $sql_statement = "SELECT ${delim}range${delim} " .
                        "FROM ${delim}numbers${delim} " .
                        "JOIN ${delim}description${delim} AS D " .
                        "ON ${delim}column_id${delim} = D.id " .
                        'WHERE (user = ? OR user IS NULL) ' .
                        'AND ( dbname = ? ';
    if( $db->{db}{content}{engine} ne 'mysql' ) {
        $sql_statement .= 'OR dbname = ? ';
        push @dbnames, basename $db->{db}{content}{DB};
    }
    $sql_statement .= ') AND dbtable = ? AND dbcolumn = ? ' .
                      # 'user' is ordered in descending order to get
                      # common value suggestions last:
                      "ORDER BY user DESC, ${delim}range${delim} ASC";
    print STDERR "$sql_statement\n" if $debug_sql;
    my $sth = $dbh->prepare( $sql_statement ) or
        $db->error( "could not prepare SELECT statement: $DBI::errstr" );
    $sth->execute( $db->{db}{content}{user},
                   @dbnames,
                   $table,
                   $column ) or
        $db->error( "Execution of $sql_statement failed: $DBI::errstr" );

    my @suggested_values;
    while( my( $id_range ) = $sth->fetchrow_array ) {
        my $id_prefix = $id_range;
        $id_prefix =~ s/^([-A-Za-z]+).*$/$1/g;

        # "delimited column":
        my $dbh = $db->{db}{content}{dbh};
        my $delim = $db->{db}{content}{delim};
        my $dcolumn = $delim . $column . $delim;
        my $history_table = $table . $RestfulDB::Defaults::history_table_suffix;
        my $max_id;
        if( defined $db->get_table_info( $history_table )) {
            $max_id =
                $dbh->selectrow_array( "SELECT max($dcolumn) " .
                                       "FROM (SELECT $dcolumn FROM " .
                                       "$delim$table$delim " .
                                       "WHERE $dcolumn LIKE ? " .
                                       "AND $dcolumn >= ? " .
                                       "UNION SELECT $dcolumn FROM " .
                                       "$delim${history_table}$delim " .
                                       "WHERE $dcolumn LIKE ? " .
                                       "AND $dcolumn >= ? ) AS " .
                                       "${delim}united${delim}",
                                       undef, $id_prefix . '%',
                                       $id_range, $id_prefix . '%',
                                       $id_range );
        } else {
            $max_id =
                $dbh->selectrow_array( "SELECT $dcolumn " .
                                       "FROM $delim$table$delim" .
                                       "WHERE $dcolumn LIKE ? " .
                                       "AND $dcolumn >= ? " .
                                       "ORDER BY $dcolumn DESC " .
                                       "LIMIT 1",
                                       undef, $id_prefix . '%',
                                       $id_range );
        }

        my $suggested_value;
        if( defined $max_id ) {
            $suggested_value = $max_id;
            # Suggest the next identifier:
            $suggested_value =~ s/-//g;
            $suggested_value ++;
            my $pos = -1;
            while( ($pos = index($max_id,'-',$pos+1)) >= 0 ) {
                $suggested_value =
                    substr( $suggested_value, 0, $pos ) . '-' .
                    substr( $suggested_value, $pos );
            }
        } else {
            $suggested_value = $id_range;
        }

        push( @suggested_values, $suggested_value );
    }

    return \@suggested_values;
}

## @method get_enumerations ($db, $table, $column)
# Returns enumeration options for a column.
#
# @param db Database object
# @param table table name
# @param column column name
# @retval array of options (can be empty)
sub get_enumerations
{
    my ($db, $table, $column) = @_;
    $db->_load_enumerations();

    if( exists $db->{enum}{$table} &&
        exists $db->{enum}{$table}{$column} ) {
        return $db->{enum}{$table}{$column};
    }

    return [];
}

sub _load_enumerations
{
    my ($db) = @_;
    return if exists $db->{enum};

    my $enums = {};
    if( $db->{db}{meta} && $db->{db}{meta}{dbh} ) {
        my $dbh = $db->{db}{meta}{dbh};
        my $delim = $db->{db}{meta}{delim};
        my $sql_statement = 'SELECT ' .
                            "dbtable AS ${delim}table${delim}, " .
                            "dbcolumn AS ${delim}column${delim}, " .
                            "${delim}option${delim} AS ${delim}option${delim} " .
                            'FROM description ' .
                            'JOIN enumeration ' .
                            'ON description.id = column_id ' .
                            'WHERE dbname = ?';
        my @dbnames = ( $db->{db}{content}{DB} );
        if( $db->{db}{content}{engine} ne 'mysql' ) {
            $sql_statement .= ' OR dbname = ?';
            push @dbnames, basename $db->{db}{content}{DB};
        }
        print STDERR "$sql_statement\n" if $debug_sql;
        my $sth = $dbh->prepare( $sql_statement ) or
            $db->error( "could not prepare SELECT statement: $DBI::errstr" );

        my $rv = $sth->execute( @dbnames );
        if( defined $rv ) {
            while( my $row = $sth->fetchrow_hashref ) {
                push @{$enums->{$row->{table}}{$row->{column}}},
                     $row->{option};
            }
        } else {
            warn "'SELECT *' failed: " . $DBI::errstr;
        }
    }

    # DBI driver for MySQL is able to extract enumeration values for
    # columns of type 'ENUM':
    if( $db->{db}{content}{engine} ne 'mysql' ) {
        $db->{enum} = $enums;
        return;
    }

    for my $table ($db->get_table_list()) {
        my $columns = $db->get_column_info( $table );
        for my $column (sort keys %$columns) {
            next if lc $columns->{$column}{TYPE_NAME} ne 'enum';
            next if !$columns->{$column}{mysql_values};

            my @values_now = @{$columns->{$column}{mysql_values}};
            if( $columns->{$column}{IS_NULLABLE} eq 'YES' ) {
                push @values_now, undef;
            }
            if( exists $enums->{$table}{$column} ) {
                my $values = $enums->{$table}{$column};
                if( @$values != @values_now ||
                    join( '@@', sort map {defined($_)?$_:''}
                          @$values )
                    ne
                    join( '@@', sort map {defined($_)?$_:''} 
                          @values_now ) ) {
                    warn 'enumeration values from MySQL table (' . 
                        join(',',sort(map {defined($_)?$_:"''"} 
                                      @values_now)) . ') ' .
                        'definition and from metatables (' .
                        join(',',sort(map {defined($_)?$_:"''"} 
                                      @$values)) .
                        ') do not ' .
                        "match for '$table.$column', taking " .
                        'MySQL definition';
                }
            }
            
            $enums->{$table}{$column} = \@values_now;
        }
    }

    $db->{enum} = $enums;
}

## @method get_set_values ($db, $table, $column)
# Returns set values options for a column.
#
# @param db Database object
# @param table table name
# @param column column name
# @retval array of options (can be empty)
sub get_set_values
{
    my ($db, $table, $column) = @_;
    $db->_load_set_values();

    if( exists $db->{set_values}{$table} &&
        exists $db->{set_values}{$table}{$column} ) {
        return $db->{set_values}{$table}{$column};
    }

    return [];
}

sub _load_set_values
{
    my ($db) = @_;
    return if exists $db->{set_values};

    my $set_values = {};
    if( $db->{db}{content}{engine} ne 'mysql' ) {
        # Currently SET data types are supported only on MySQL
        $db->{set_values} = $set_values;
        return;
    }

    for my $table ($db->get_table_list()) {
        my $columns = $db->get_column_info( $table );
        for my $column (sort keys %$columns) {
            next if lc $columns->{$column}{TYPE_NAME} ne 'set';
            next if !$columns->{$column}{mysql_values};

            $set_values->{$table}{$column} =
                $columns->{$column}{mysql_values};
        }
    }

    $db->{set_values} = $set_values;
}

## @method get_primary_key_columns ($db, $table)
# Returns array of the columns which are declared as primary key.
#
# @param db Database object
# @param table table name
# @retval array of "NON NULL" columns 
#  (N.B. method can return array with one primary key column; with N
#   primery key columns when composite primary key is using; returing
#   array can be empty if primary key is not declared)
sub get_primary_key_columns
{
    my( $db, $table ) = @_;
    
    my $dbh = $db->{db}{content}{dbh};
    my @primary_key_columns = $dbh->primary_key( undef, undef, $table );

    return @primary_key_columns;
}

sub _is_view
{
    my( $db, $table ) = @_;
    my $table_info = $db->get_table_info( $table );
    return $table_info->[0][3] eq 'VIEW';
}

sub is_view
{
    my( $db, $table ) = @_;
    my $tables_info = $db->get_tables_info;
    return $tables_info->{$table} eq 'VIEW';
}

sub get_db_username
{
    my( $db, $username_hash ) = @_;

    my $dbh = $db->{db}{meta}{dbh};
    my $sql_statement = 'SELECT db_username FROM db_users ' .
                            'WHERE username_hash = ?';
    print STDERR "$sql_statement\n" if $debug_sql;
    my $sth = $dbh->prepare( $sql_statement ) or
        $db->error( "could not prepare SELECT statement: $DBI::errstr" );

    $sth->execute( $username_hash ) or
        $db->error( "'SELECT *' failed: " . $DBI::errstr );

    my $username = $sth->fetchrow();

    return $username;
}

sub metatables_version
{
    my( $db ) = @_;
    return $db->{db}{meta}{metatables_version}
        if exists $db->{db}{meta}{metatables_version};

    if( !$db->{db}{meta}{dbh} ) {
        return $db->{db}{meta}{metatables_version} = undef;
    }

    my $sth = $db->{db}{meta}{dbh}->prepare( 'SELECT number FROM version' );
    $sth->execute or $db->error( "'SELECT' failed: " . $DBI::errstr );

    ( $db->{db}{meta}{metatables_version} ) = $sth->fetchrow;
    return $db->{db}{meta}{metatables_version};
}

sub error
{
    my( $db, $message ) = @_;
    if( $db->{db}{content}{engine} eq 'mysql' ) {
        if( defined $DBI::err && ( $DBI::err == 1142 || $DBI::err == 1143 ) ) {
            # ER_TABLEACCESS_DENIED_ERROR or ER_COLUMNACCESS_DENIED_ERROR
            UnauthorizedException->throw( $message );
        } elsif( defined $DBI::err && $DBI::err == 1062 ) {
            DuplicateEntryException->throw( $message );
        } else {
            die $message;
        }
    } else {
        if( defined $DBI::err && $DBI::err == 19 ) {
            DuplicateEntryException->throw( $message );
        }
        die $message;
    }
}

1;
