File Coverage

blib/lib/DBIx/Schema/DSL/Dumper.pm

Criterion	Covered	Total	%
statement	24	162	14.8
branch	0	84	0.0
condition	0	45	0.0
subroutine	8	16	50.0
pod	0	1	0.0
total	32	308	10.3

package DBIx::Schema::DSL::Dumper;
use 5.008001;
use strict;
use warnings;
use DBIx::Inspector;
use DBIx::Inspector::Iterator;
use Carp ();

our $VERSION = "0.05";

# XXX copy from SQL::Translator::Parser::DBI-1.59
use constant DRIVERS => {
    mysql            => 'MySQL',
    odbc             => 'SQLServer',
    oracle           => 'Oracle',
    pg               => 'PostgreSQL',
    sqlite           => 'SQLite',
    sybase           => 'Sybase',
    pg               => 'PostgreSQL',
    db2              => 'DB2',
};

sub dump {
    my $class = shift;
    my %args = @_==1 ? %{$_[0]} : @_;

    my $dbh = $args{dbh} or Carp::croak("missing mandatory parameter 'dbh'");

    my $inspector = DBIx::Inspector->new(dbh => $dbh);

    my $ret = "";

    if ( ref $args{tables} eq "ARRAY" ) {
        for my $table_name (@{ $args{tables} }) {
            $ret .= _render_table($inspector->table($table_name), \%args);
        }
    }
    elsif ( $args{tables} ) {
        $ret .= _render_table($inspector->table($args{tables}), \%args);
    }
    else {
        my $pkg = $args{pkg} or Carp::croak("missing mandatory parameter 'pkg'");

        $ret .= "package ${pkg};\n";
        $ret .= "use strict;\n";
        $ret .= "use warnings;\n";
        $ret .= "use DBIx::Schema::DSL;\n";
        $ret .= "\n";

        my $db_type = $dbh->{'Driver'}{'Name'} or die 'Cannot determine DBI type';
        my $driver  = DRIVERS->{ lc $db_type } or warn "$db_type not supported";
        $ret .= sprintf("database '%s';\n", $driver) if $driver;
        $ret .= "default_unsigned;\n" if $args{default_unsigned};
        $ret .= "default_not_null;\n" if $args{default_not_null};
        $ret .= "\n";

        if ($args{table_options}) {
            $ret .= "add_table_options\n";
            my @table_options;
            for my $key (keys %{$args{table_options}}) {
                push @table_options => sprintf("    '%s' => '%s'", $key, $args{table_options}->{$key})
            }
            $ret .= join ",\n", @table_options;
            $ret .= ";\n\n";
        }

        for my $table_info (sort { $a->name cmp $b->name } $inspector->tables) {
            $ret .= _render_table($table_info, \%args);
        }
        $ret .= "1;\n";
    }

    return $ret;
}


sub _render_table {
    my ($table_info, $args) = @_;

    my $ret = "";

    $ret .= sprintf("create_table '%s' => columns {\n", $table_info->name);

    my @primary_key_names = map { $_->name } $table_info->primary_key;

    $args = +{ %$args, primary_key_names => \@primary_key_names }; # XXX

    for my $col ($table_info->columns) {
        $ret .= _render_column($col, $table_info, $args);
    }

    $ret .= _render_index($table_info, $args);

    $ret .= "};\n\n";

    return $ret;
}

sub _render_column {
    my ($column_info, $table_info, $args) = @_;

    my $ret = "";
    $ret .= sprintf("    column '%s'", $column_info->name);

    my ($type, @opt) = split / /, $column_info->type_name;

    if ($column_info->{MYSQL_TYPE_NAME}) {
        push @opt => split / /, $column_info->{MYSQL_TYPE_NAME};
    }

    $ret .= sprintf(", '%s'", $type);

    my %opt = map { lc($_) => 1 } @opt;

    if (lc($type) =~ /^(enum|set)$/) {
        # XXX
        $ret .= sprintf(" => ['%s']", join "','", @{$column_info->{MYSQL_VALUES}});
    }

    $ret .= ", signed"   if $opt{signed};
    $ret .= ", unsigned" if $opt{unsigned} && !$args->{default_unsigned};

    if (defined $column_info->column_size) {
        my $column_size;

        if (lc($type) eq 'decimal') {
            # XXX
            $column_size = sprintf("[%d, %d]", $column_info->column_size, $column_info->{DECIMAL_DIGITS});
        }
        elsif (lc($type) =~ /^(enum|set)$/) {
            ;;
        }
        # TODO use DBIx::Schema::DSL->context->default_varchar_size
        elsif (lc($type) eq 'varchar' && $column_info->column_size == 255) {
            ;;
        }
        elsif (
            lc($type) =~ /^(int|integer)$/ &&
            (
                $opt{unsigned} && $column_info->column_size == 10
                or
                !$opt{unsigned} && $column_info->column_size == 11
            )
        ) {
            ;;
        }
        elsif ($column_info->{MYSQL_TYPE_NAME} && $column_info->{MYSQL_TYPE_NAME} !~ $column_info->column_size) {
            ;;
        }
        else {
            $column_size = $column_info->column_size;
        }


        $ret .= sprintf(", size => %s", $column_size) if $column_size;
    }

    $ret .= ", null"     if $column_info->nullable;
    $ret .= ", not_null" if !$column_info->nullable && !$args->{default_not_null};

    if (defined $column_info->column_def) {
        my $column_def = $column_info->column_def;

        if ($type =~ /^(TIMESTAMP|DATETIME)$/ && $column_def eq 'CURRENT_TIMESTAMP') {
            $ret .= sprintf(", default => \\'%s'", $column_def)
        }
        else {
            $ret .= sprintf(", default => '%s'", $column_def)
        }
    }

    if (@{$args->{primary_key_names}} == 1 && $args->{primary_key_names}->[0] eq $column_info->name) {
        $ret .= ", primary_key"
    }

    if (
        $opt{auto_increment} or
        # XXX
        ($args->{dbh}->{'Driver'}{'Name'} eq 'mysql' && $column_info->{MYSQL_IS_AUTO_INCREMENT})
    ) {
        $ret .= ", auto_increment"
    }

    $ret .= ";\n";

    return $ret;
}

sub _render_index {
    my ($table_info, $args) = @_;

    my @fk_list = $table_info->fk_foreign_keys;

    my $ret = "";

    # primary key
    if (@{$args->{primary_key_names}} > 1) {
        $ret .= "\n";
        $ret .= sprintf("    set_primary_key('%s');\n", join "','", @{$args->{primary_key_names}});
    }

    # index
    {
        my $itr = _statistics_info($args->{dbh}, $table_info->schema, $table_info->name);
        my %pk_name = map { $_ => 1 } @{$args->{primary_key_names}};
        my %fk_name = map { $_->fkcolumn_name => 1 } @fk_list;

        my %index_info;
        while (my $index_key = $itr->next) {
            next if $pk_name{$index_key->column_name};
            next if $fk_name{$index_key->column_name};

            push @{$index_info{$index_key->index_name}} => $index_key;
        }

        $ret .= "\n" if %index_info;
        for my $index_name (sort keys %index_info) {
            my @index_keys = @{$index_info{$index_name}};
            my @column_names = map { $_->column_name } @index_keys;

            $ret .= sprintf("    add_%sindex('%s' => [%s]%s);\n",
                        $index_keys[0]->non_unique ? '' : 'unique_',
                        $index_name,
                        (join ",", (map { q{'}.$_.q{'} } @column_names)),
                        $index_keys[0]->non_unique && $index_keys[0]->type ? sprintf(", '%s'", $index_keys[0]->type) : '',
                    );
        }
    }

    # foreign key
    # FIXME not supported UPDATE_RULE, DELETE_RULE
    if (@fk_list) {
        $ret .= "\n";
        for my $fk (@fk_list) {
            if ($fk->pktable_name && $fk->fkcolumn_name eq sprintf('%s_id', $fk->pktable_name)) {
                $ret .= sprintf("    belongs_to('%s')\n", $fk->pktable_name)
            }
            elsif ($fk->fkcolumn_name eq 'id' && $fk->pkcolumn_name eq sprintf('%s_id', $fk->fktable_name)) {

                my $itr = _statistics_info($args->{dbh}, $table_info->schema, $fk->pktable_name);
                while (my $index_key = $itr->next) {
                    if ($index_key->column_name eq $fk->pkcolumn_name) {
                        my $has = $index_key->non_unique ? 'has_many' : 'has_one';
                        $ret .= sprintf("    %s('%s')\n", $has, $fk->pktable_name);
                        last;
                    }
                }
            }
            elsif ($fk->fkcolumn_name && $fk->pktable_name && $fk->pkcolumn_name) {
                $ret .= sprintf("    foreign_key('%s','%s','%s')\n", $fk->fkcolumn_name, $fk->pktable_name, $fk->pkcolumn_name);
            }
        }
    }

    return $ret;
}

# EXPERIMENTAL: https://metacpan.org/pod/DBI#statistics_info
sub _statistics_info {
    my ($dbh, $schema, $table_name) = @_;

    my $sth;
    if ($dbh->{'Driver'}{'Name'} eq 'mysql') {
        # TODO p-r DBD::mysqld ??
        my $sql = q{
            SELECT
                 *
            FROM
                INFORMATION_SCHEMA.STATISTICS
            WHERE
                table_schema = ?
                AND table_name = ?
        };
        $sth = $dbh->prepare($sql);
        $sth->execute($schema, $table_name);
    }
    else {
        $sth = $dbh->statistics_info(undef, undef, $table_name, undef, undef);
    }

    DBIx::Inspector::Iterator->new(
        sth => $sth,
        callback => sub {
            # TODO p-r DBIx::Inspector ??
            my $row = shift;
            DBIx::Inspector::Statics->new($row);
        },
    );
}

package # hide from PAUSE
    DBIx::Inspector::Statics;

sub new {
    my $class = shift;
    my %args = @_ == 1 ? %{ $_[0] } : @_;
    bless {%args}, $class;
}

{
    no strict 'refs';
    for my $k (
        qw/
            TABLE_CAT
            TABLE_SCHEM
            TABLE_NAME
            NON_UNIQUE
            INDEX_QUALIFIER
            INDEX_NAME
            TYPE
            ORDINAL_POSITION
            COLUMN_NAME
            ASC_OR_DESC
            CARDINALITY
            PAGES
            FILTER_CONDITION
        /
      )
    {
        *{ __PACKAGE__ . "::" . lc($k) } = sub { $_[0]->{$k} };
    }
}


1;
__END__