[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / DBI / Sybase.pm

package DBIx::Class::Schema::Loader::DBI::Sybase;

use strict;
use warnings;
use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common';
use mro 'c3';
use List::Util 'any';
use namespace::clean;

use DBIx::Class::Schema::Loader::Table::Sybase ();

our $VERSION = '0.07047';

=head1 NAME

DBIx::Class::Schema::Loader::DBI::Sybase - DBIx::Class::Schema::Loader::DBI
Sybase ASE Implementation.

=head1 DESCRIPTION

See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.

This class reblesses into the L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server> class for connections to MSSQL.

=cut

sub _rebless {
    my $self = shift;

    my $dbh = $self->schema->storage->dbh;
    my $DBMS_VERSION = @{$dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2];
    if ($DBMS_VERSION =~ /^Microsoft /i) {
        $DBMS_VERSION =~ s/\s/_/g;
        my $subclass = "DBIx::Class::Schema::Loader::DBI::Sybase::$DBMS_VERSION";
        if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
            bless $self, $subclass;
            $self->_rebless;
        }
    }
}

sub _system_databases {
    return (qw/
        master model sybsystemdb sybsystemprocs tempdb
    /);
}

sub _system_tables {
    return (qw/
        sysquerymetrics
    /);
}

sub _setup {
    my $self = shift;

    $self->next::method(@_);

    $self->preserve_case(1);

    my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');

    if (ref $self->db_schema eq 'HASH') {
        if (keys %{ $self->db_schema } < 2) {
            my ($db) = keys %{ $self->db_schema };

            $db ||= $current_db;

            if ($db eq '%') {
                my $owners = $self->db_schema->{$db};

                my $db_names = $self->dbh->selectcol_arrayref(<<'EOF');
SELECT name
FROM master.dbo.sysdatabases
EOF

                my @dbs;

                foreach my $db_name (@$db_names) {
                    push @dbs, $db_name
                        unless any { $_ eq $db_name } $self->_system_databases;
                }

                $self->db_schema({});

                DB: foreach my $db (@dbs) {
                    if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') || $owners eq '%')) {
                        my @owners;

                        foreach my $owner (@$owners) {
                            push @owners, $owner
                                if defined $self->_uid($db, $owner);
                        }

                        next DB unless @owners;

                        $self->db_schema->{$db} = \@owners;
                    }
                    else {
                        # for post-processing below
                        $self->db_schema->{$db} = '%';
                    }
                }

                $self->qualify_objects(1);
            }
            else {
                if ($db ne $current_db) {
                    $self->dbh->do("USE [$db]");

                    $self->qualify_objects(1);
                }
            }
        }
        else {
            $self->qualify_objects(1);
        }
    }
    elsif (ref $self->db_schema eq 'ARRAY' || (not defined $self->db_schema)) {
        my $owners = $self->db_schema;
        $owners ||= [ $self->dbh->selectrow_array('SELECT user_name()') ];

        $self->qualify_objects(1) if @$owners > 1;

        $self->db_schema({ $current_db => $owners });
    }

    foreach my $db (keys %{ $self->db_schema }) {
        if ($self->db_schema->{$db} eq '%') {
            my $owners = $self->dbh->selectcol_arrayref(<<"EOF");
SELECT name
FROM [$db].dbo.sysusers
WHERE uid <> gid
EOF
            $self->db_schema->{$db} = $owners;

            $self->qualify_objects(1);
        }
    }
}

sub _tables_list {
    my ($self) = @_;

    my @tables;

    while (my ($db, $owners) = each %{ $self->db_schema }) {
        foreach my $owner (@$owners) {
            my ($uid) = $self->_uid($db, $owner);

            my $table_names = $self->dbh->selectcol_arrayref(<<"EOF");
SELECT name
FROM [$db].dbo.sysobjects
WHERE uid = $uid
    AND type IN ('U', 'V')
EOF

            TABLE: foreach my $table_name (@$table_names) {
                next TABLE if any { $_ eq $table_name } $self->_system_tables;

                push @tables, DBIx::Class::Schema::Loader::Table::Sybase->new(
                    loader   => $self,
                    name     => $table_name,
                    database => $db,
                    schema   => $owner,
                );
            }
        }
    }

    return $self->_filter_tables(\@tables);
}

sub _uid {
    my ($self, $db, $owner) = @_;

    my ($uid) = $self->dbh->selectrow_array(<<"EOF");
SELECT uid
FROM [$db].dbo.sysusers
WHERE name = @{[ $self->dbh->quote($owner) ]}
EOF

    return $uid;
}

sub _table_columns {
    my ($self, $table) = @_;

    my $db    = $table->database;
    my $owner = $table->schema;

    my $columns = $self->dbh->selectcol_arrayref(<<"EOF");
SELECT c.name
FROM [$db].dbo.syscolumns c
JOIN [$db].dbo.sysobjects o
    ON c.id = o.id
WHERE o.name = @{[ $self->dbh->quote($table->name) ]}
    AND o.type IN ('U', 'V')
    AND o.uid  = @{[ $self->_uid($db, $owner) ]}
ORDER BY c.colid ASC
EOF

    return $columns;
}

sub _table_pk_info {
    my ($self, $table) = @_;

    my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');

    my $db = $table->database;

    $self->dbh->do("USE [$db]");

    local $self->dbh->{FetchHashKeyName} = 'NAME_lc';

    my $sth = $self->dbh->prepare(<<"EOF");
sp_pkeys @{[ $self->dbh->quote($table->name) ]},
    @{[ $self->dbh->quote($table->schema) ]},
    @{[ $self->dbh->quote($db) ]}
EOF
    $sth->execute;

    my @keydata;

    while (my $row = $sth->fetchrow_hashref) {
        push @keydata, $row->{column_name};
    }

    $self->dbh->do("USE [$current_db]");

    return \@keydata;
}

sub _table_fk_info {
    my ($self, $table) = @_;

    my $db    = $table->database;
    my $owner = $table->schema;

    my $sth = $self->dbh->prepare(<<"EOF");
SELECT sr.reftabid, sd2.name, sr.keycnt,
    fokey1,  fokey2,   fokey3,   fokey4,   fokey5,   fokey6,   fokey7,   fokey8,
    fokey9,  fokey10,  fokey11,  fokey12,  fokey13,  fokey14,  fokey15,  fokey16,
    refkey1, refkey2,  refkey3,  refkey4,  refkey5,  refkey6,  refkey7,  refkey8,
    refkey9, refkey10, refkey11, refkey12, refkey13, refkey14, refkey15, refkey16
FROM [$db].dbo.sysreferences sr
JOIN [$db].dbo.sysobjects so1
    ON sr.tableid = so1.id
JOIN [$db].dbo.sysusers su1
    ON so1.uid = su1.uid
JOIN master.dbo.sysdatabases sd2
    ON sr.pmrydbid = sd2.dbid
WHERE so1.name = @{[ $self->dbh->quote($table->name) ]}
    AND su1.name = @{[ $self->dbh->quote($table->schema) ]}
EOF
    $sth->execute;

    my @rels;

    REL: while (my @rel = $sth->fetchrow_array) {
        my ($remote_tab_id, $remote_db, $key_cnt) = splice @rel, 0, 3;

        my ($remote_tab_owner, $remote_tab_name) =
            $self->dbh->selectrow_array(<<"EOF");
SELECT su.name, so.name
FROM [$remote_db].dbo.sysusers su
JOIN [$remote_db].dbo.sysobjects so
    ON su.uid = so.uid
WHERE so.id = $remote_tab_id
EOF

        next REL
            unless any { $_ eq $remote_tab_owner }
                @{ $self->db_schema->{$remote_db} || [] };

        my @local_col_ids  = splice @rel, 0, 16;
        my @remote_col_ids = splice @rel, 0, 16;

        @local_col_ids  = splice @local_col_ids,  0, $key_cnt;
        @remote_col_ids = splice @remote_col_ids, 0, $key_cnt;

        my $remote_table = DBIx::Class::Schema::Loader::Table::Sybase->new(
            loader   => $self,
            name     => $remote_tab_name,
            database => $remote_db,
            schema   => $remote_tab_owner,
        );

        my $all_local_cols  = $self->_table_columns($table);
        my $all_remote_cols = $self->_table_columns($remote_table);

        my @local_cols  = map $all_local_cols->[$_-1],  @local_col_ids;
        my @remote_cols = map $all_remote_cols->[$_-1], @remote_col_ids;

        next REL if    (any { not defined $_ } @local_cols)
                    || (any { not defined $_ } @remote_cols);

        push @rels, {
            local_columns  => \@local_cols,
            remote_table   => $remote_table,
            remote_columns => \@remote_cols,
        };
    };

    return \@rels;
}

sub _table_uniq_info {
    my ($self, $table) = @_;

    my $db    = $table->database;
    my $owner = $table->schema;
    my $uid   = $self->_uid($db, $owner);

    my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');

    $self->dbh->do("USE [$db]");

    my $sth = $self->dbh->prepare(<<"EOF");
SELECT si.name, si.indid, si.keycnt
FROM [$db].dbo.sysindexes si
JOIN [$db].dbo.sysobjects so
    ON si.id = so.id
WHERE so.name = @{[ $self->dbh->quote($table->name) ]}
    AND so.uid = $uid
    AND si.indid > 0
    AND si.status & 2048 <> 2048
    AND si.status2 & 2 = 2
EOF
    $sth->execute;

    my %uniqs;

    while (my ($ind_name, $ind_id, $key_cnt) = $sth->fetchrow_array) {
        COLS: foreach my $col_idx (1 .. ($key_cnt+1)) {
            my ($next_col) = $self->dbh->selectrow_array(<<"EOF");
SELECT index_col(
    @{[ $self->dbh->quote($table->name) ]},
    $ind_id, $col_idx, $uid
)
EOF
            last COLS unless defined $next_col;

            push @{ $uniqs{$ind_name} }, $next_col;
        }
    }

    $self->dbh->do("USE [$current_db]");

    return [ map { [ $_ => $uniqs{$_} ] } sort keys %uniqs ];
}

sub _columns_info_for {
    my $self    = shift;
    my ($table) = @_;
    my $result  = $self->next::method(@_);

    my $db    = $table->database;
    my $owner = $table->schema;
    my $uid   = $self->_uid($db, $owner);

    local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
    my $sth = $self->dbh->prepare(<<"EOF");
SELECT c.name, bt.name base_type, ut.name user_type, c.prec prec, c.scale scale, c.length len, c.cdefault dflt_id, c.computedcol comp_id, (c.status & 0x80) is_id
FROM [$db].dbo.syscolumns c
LEFT JOIN [$db].dbo.sysobjects o  ON c.id       = o.id
LEFT JOIN [$db].dbo.systypes   bt ON c.type     = bt.type
LEFT JOIN [$db].dbo.systypes   ut ON c.usertype = ut.usertype
WHERE o.name = @{[ $self->dbh->quote($table) ]}
    AND o.uid = $uid
    AND o.type IN ('U', 'V')
EOF
    $sth->execute;
    my $info = $sth->fetchall_hashref('name');

    while (my ($col, $res) = each %$result) {
        $res->{data_type} = $info->{$col}{user_type} || $info->{$col}{base_type};

        if ($info->{$col}{is_id}) {
            $res->{is_auto_increment} = 1;
        }
        $sth->finish;

        # column has default value
        if (my $default_id = $info->{$col}{dflt_id}) {
            my $sth = $self->dbh->prepare(<<"EOF");
SELECT cm.id, cm.text
FROM [$db].dbo.syscomments cm
WHERE cm.id = $default_id
EOF
            $sth->execute;

            if (my ($d_id, $default) = $sth->fetchrow_array) {
                my $constant_default = ($default =~ /^DEFAULT \s+ (\S.*\S)/ix)
                    ? $1
                    : $default;

                $constant_default = substr($constant_default, 1, length($constant_default) - 2)
                    if (   substr($constant_default, 0, 1) =~ m{['"\[]}
                        && substr($constant_default, -1)   =~ m{['"\]]});

                $res->{default_value} = $constant_default;
            }
        }

        # column is a computed value
        if (my $comp_id = $info->{$col}{comp_id}) {
            my $sth = $self->dbh->prepare(<<"EOF");
SELECT cm.id, cm.text
FROM [$db].dbo.syscomments cm
WHERE cm.id = $comp_id
EOF
            $sth->execute;
            if (my ($c_id, $comp) = $sth->fetchrow_array) {
                my $function = ($comp =~ /^AS \s+ (\S+)/ix) ? $1 : $comp;
                $res->{default_value} = \$function;

                if ($function =~ /^getdate\b/) {
                    $res->{inflate_datetime} = 1;
                }

                delete $res->{size};
                $res->{data_type} = undef;
            }
        }

        if (my $data_type = $res->{data_type}) {
            if ($data_type eq 'int') {
                $data_type = $res->{data_type} = 'integer';
            }
            elsif ($data_type eq 'decimal') {
                $data_type = $res->{data_type} = 'numeric';
            }
            elsif ($data_type eq 'float') {
                $data_type = $res->{data_type}
                    = ($info->{$col}{len} <= 4 ? 'real' : 'double precision');
            }

            if ($data_type eq 'timestamp') {
                $res->{inflate_datetime} = 0;
            }

            if ($data_type =~ /^(?:text|unitext|image|bigint|integer|smallint|tinyint|real|double|double precision|float|date|time|datetime|smalldatetime|money|smallmoney|timestamp|bit)\z/i) {
                delete $res->{size};
            }
            elsif ($data_type eq 'numeric') {
                my ($prec, $scale) = @{$info->{$col}}{qw/prec scale/};

                if (!defined $prec && !defined $scale) {
                    $data_type = $res->{data_type} = 'integer';
                    delete $res->{size};
                }
                elsif ($prec == 18 && $scale == 0) {
                    delete $res->{size};
                }
                else {
                    $res->{size} = [ $prec, $scale ];
                }
            }
            elsif ($data_type =~ /char/) {
                $res->{size} = $info->{$col}{len};

                if ($data_type =~ /^(?:unichar|univarchar)\z/i) {
                    $res->{size} /= 2;
                }
                elsif ($data_type =~ /^n(?:var)?char\z/i) {
                    my ($nchar_size) = $self->dbh->selectrow_array('SELECT @@ncharsize');

                    $res->{size} /= $nchar_size;
                }
            }
        }
    }

    return $result;
}

=head1 SEE ALSO

L<DBIx::Class::Schema::Loader::DBI::Sybase::Common>,
L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
L<DBIx::Class::Schema::Loader::DBI>

=head1 AUTHORS

See L<DBIx::Class::Schema::Loader/AUTHORS>.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut

1;
# vim:et sts=4 sw=4 tw=0:
Commit	Line	Data
fe67d343	1	package DBIx::Class::Schema::Loader::DBI::Sybase;
	2
	3	use strict;
	4	use warnings;
de82711a	5	use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common';
942bd5e0	6	use mro 'c3';
ecf22f0a	7	use List::Util 'any';
c4a69b87	8	use namespace::clean;
	9
	10	use DBIx::Class::Schema::Loader::Table::Sybase ();
fe67d343	11
306bf770	12	our $VERSION = '0.07047';
fe67d343	13
	14	=head1 NAME
	15
5163dc4a	16	DBIx::Class::Schema::Loader::DBI::Sybase - DBIx::Class::Schema::Loader::DBI
5163dc4a	17	Sybase ASE Implementation.
fe67d343	18
	19	=head1 DESCRIPTION
	20
5163dc4a	21	See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
fe67d343	22
c4a69b87	23	This class reblesses into the L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server> class for connections to MSSQL.
bc1cb85e	24
c4a69b87	25	=cut
565335e6	26
fe67d343	27	sub _rebless {
	28	my $self = shift;
	29
	30	my $dbh = $self->schema->storage->dbh;
	31	my $DBMS_VERSION = @{$dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2];
	32	if ($DBMS_VERSION =~ /^Microsoft /i) {
b1e43108	33	$DBMS_VERSION =~ s/\s/_/g;
b1e43108	34	my $subclass = "DBIx::Class::Schema::Loader::DBI::Sybase::$DBMS_VERSION";
65f74457	35	if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
	36	bless $self, $subclass;
	37	$self->_rebless;
494e0205	38	}
fe67d343	39	}
	40	}
	41
c4a69b87	42	sub _system_databases {
	43	return (qw/
	44	master model sybsystemdb sybsystemprocs tempdb
	45	/);
	46	}
	47
	48	sub _system_tables {
	49	return (qw/
	50	sysquerymetrics
	51	/);
	52	}
	53
	54	sub _setup {
	55	my $self = shift;
	56
	57	$self->next::method(@_);
	58
	59	$self->preserve_case(1);
	60
	61	my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');
	62
	63	if (ref $self->db_schema eq 'HASH') {
	64	if (keys %{ $self->db_schema } < 2) {
	65	my ($db) = keys %{ $self->db_schema };
	66
	67	$db \|\|= $current_db;
	68
	69	if ($db eq '%') {
	70	my $owners = $self->db_schema->{$db};
	71
	72	my $db_names = $self->dbh->selectcol_arrayref(<<'EOF');
	73	SELECT name
	74	FROM master.dbo.sysdatabases
	75	EOF
	76
	77	my @dbs;
	78
	79	foreach my $db_name (@$db_names) {
	80	push @dbs, $db_name
	81	unless any { $_ eq $db_name } $self->_system_databases;
	82	}
	83
	84	$self->db_schema({});
	85
	86	DB: foreach my $db (@dbs) {
	87	if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') \|\| $owners eq '%')) {
	88	my @owners;
	89
	90	foreach my $owner (@$owners) {
	91	push @owners, $owner
	92	if defined $self->_uid($db, $owner);
	93	}
	94
	95	next DB unless @owners;
	96
	97	$self->db_schema->{$db} = \@owners;
	98	}
	99	else {
	100	# for post-processing below
	101	$self->db_schema->{$db} = '%';
	102	}
	103	}
	104
	105	$self->qualify_objects(1);
106	}
107	else {
108	if ($db ne $current_db) {
109	$self->dbh->do("USE [$db]");
110
111	$self->qualify_objects(1);
112	}
113	}
114	}
115	else {
116	$self->qualify_objects(1);
117	}
118	}
119	elsif (ref $self->db_schema eq 'ARRAY' \|\| (not defined $self->db_schema)) {
120	my $owners = $self->db_schema;
121	$owners \|\|= [ $self->dbh->selectrow_array('SELECT user_name()') ];
122
123	$self->qualify_objects(1) if @$owners > 1;
124
125	$self->db_schema({ $current_db => $owners });
126	}
127
128	foreach my $db (keys %{ $self->db_schema }) {
129	if ($self->db_schema->{$db} eq '%') {
130	my $owners = $self->dbh->selectcol_arrayref(<<"EOF");
131	SELECT name
132	FROM [$db].dbo.sysusers
133	WHERE uid <> gid
134	EOF
135	$self->db_schema->{$db} = $owners;
136
137	$self->qualify_objects(1);
138	}
139	}
140	}
141
8f65b7e5	142	sub _tables_list {
5784b2b9	143	my ($self) = @_;
8f65b7e5	144
c4a69b87	145	my @tables;
8f65b7e5	146
c4a69b87	147	while (my ($db, $owners) = each %{ $self->db_schema }) {
	148	foreach my $owner (@$owners) {
	149	my ($uid) = $self->_uid($db, $owner);
8f65b7e5	150
c4a69b87	151	my $table_names = $self->dbh->selectcol_arrayref(<<"EOF");
	152	SELECT name
	153	FROM [$db].dbo.sysobjects
	154	WHERE uid = $uid
	155	AND type IN ('U', 'V')
	156	EOF
	157
	158	TABLE: foreach my $table_name (@$table_names) {
	159	next TABLE if any { $_ eq $table_name } $self->_system_tables;
	160
	161	push @tables, DBIx::Class::Schema::Loader::Table::Sybase->new(
	162	loader => $self,
	163	name => $table_name,
	164	database => $db,
	165	schema => $owner,
	166	);
	167	}
	168	}
	169	}
8f65b7e5	170
5784b2b9	171	return $self->_filter_tables(\@tables);
8f65b7e5	172	}
8f65b7e5	173
c4a69b87	174	sub _uid {
	175	my ($self, $db, $owner) = @_;
	176
	177	my ($uid) = $self->dbh->selectrow_array(<<"EOF");
	178	SELECT uid
	179	FROM [$db].dbo.sysusers
	180	WHERE name = @{[ $self->dbh->quote($owner) ]}
	181	EOF
	182
	183	return $uid;
	184	}
	185
fe67d343	186	sub _table_columns {
	187	my ($self, $table) = @_;
	188
c4a69b87	189	my $db = $table->database;
	190	my $owner = $table->schema;
	191
	192	my $columns = $self->dbh->selectcol_arrayref(<<"EOF");
9a55cbd2	193	SELECT c.name
c4a69b87	194	FROM [$db].dbo.syscolumns c
	195	JOIN [$db].dbo.sysobjects o
	196	ON c.id = o.id
	197	WHERE o.name = @{[ $self->dbh->quote($table->name) ]}
	198	AND o.type IN ('U', 'V')
	199	AND o.uid = @{[ $self->_uid($db, $owner) ]}
	200	ORDER BY c.colid ASC
	201	EOF
fe67d343	202
	203	return $columns;
	204	}
	205
	206	sub _table_pk_info {
	207	my ($self, $table) = @_;
	208
c4a69b87	209	my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');
	210
	211	my $db = $table->database;
	212
	213	$self->dbh->do("USE [$db]");
	214
	215	local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
	216
	217	my $sth = $self->dbh->prepare(<<"EOF");
494e0205	218	sp_pkeys @{[ $self->dbh->quote($table->name) ]},
c4a69b87	219	@{[ $self->dbh->quote($table->schema) ]},
	220	@{[ $self->dbh->quote($db) ]}
	221	EOF
fe67d343	222	$sth->execute;
	223
	224	my @keydata;
	225
	226	while (my $row = $sth->fetchrow_hashref) {
c9373b79	227	push @keydata, $row->{column_name};
fe67d343	228	}
fe67d343	229
c4a69b87	230	$self->dbh->do("USE [$current_db]");
c4a69b87	231
fe67d343	232	return \@keydata;
	233	}
	234
	235	sub _table_fk_info {
	236	my ($self, $table) = @_;
	237
c4a69b87	238	my $db = $table->database;
	239	my $owner = $table->schema;
	240
	241	my $sth = $self->dbh->prepare(<<"EOF");
	242	SELECT sr.reftabid, sd2.name, sr.keycnt,
	243	fokey1, fokey2, fokey3, fokey4, fokey5, fokey6, fokey7, fokey8,
	244	fokey9, fokey10, fokey11, fokey12, fokey13, fokey14, fokey15, fokey16,
	245	refkey1, refkey2, refkey3, refkey4, refkey5, refkey6, refkey7, refkey8,
	246	refkey9, refkey10, refkey11, refkey12, refkey13, refkey14, refkey15, refkey16
	247	FROM [$db].dbo.sysreferences sr
	248	JOIN [$db].dbo.sysobjects so1
	249	ON sr.tableid = so1.id
	250	JOIN [$db].dbo.sysusers su1
	251	ON so1.uid = su1.uid
	252	JOIN master.dbo.sysdatabases sd2
	253	ON sr.pmrydbid = sd2.dbid
	254	WHERE so1.name = @{[ $self->dbh->quote($table->name) ]}
	255	AND su1.name = @{[ $self->dbh->quote($table->schema) ]}
	256	EOF
fe67d343	257	$sth->execute;
fe67d343	258
c4a69b87	259	my @rels;
0852b7b8	260
c4a69b87	261	REL: while (my @rel = $sth->fetchrow_array) {
c4a69b87	262	my ($remote_tab_id, $remote_db, $key_cnt) = splice @rel, 0, 3;
dc379dc6	263
c4a69b87	264	my ($remote_tab_owner, $remote_tab_name) =
	265	$self->dbh->selectrow_array(<<"EOF");
	266	SELECT su.name, so.name
	267	FROM [$remote_db].dbo.sysusers su
	268	JOIN [$remote_db].dbo.sysobjects so
	269	ON su.uid = so.uid
	270	WHERE so.id = $remote_tab_id
	271	EOF
dc379dc6	272
c4a69b87	273	next REL
	274	unless any { $_ eq $remote_tab_owner }
	275	@{ $self->db_schema->{$remote_db} \|\| [] };
dc379dc6	276
c4a69b87	277	my @local_col_ids = splice @rel, 0, 16;
c4a69b87	278	my @remote_col_ids = splice @rel, 0, 16;
0852b7b8	279
c4a69b87	280	@local_col_ids = splice @local_col_ids, 0, $key_cnt;
c4a69b87	281	@remote_col_ids = splice @remote_col_ids, 0, $key_cnt;
0852b7b8	282
c4a69b87	283	my $remote_table = DBIx::Class::Schema::Loader::Table::Sybase->new(
	284	loader => $self,
	285	name => $remote_tab_name,
	286	database => $remote_db,
	287	schema => $remote_tab_owner,
	288	);
0852b7b8	289
c4a69b87	290	my $all_local_cols = $self->_table_columns($table);
c4a69b87	291	my $all_remote_cols = $self->_table_columns($remote_table);
0852b7b8	292
c4a69b87	293	my @local_cols = map $all_local_cols->[$_-1], @local_col_ids;
c4a69b87	294	my @remote_cols = map $all_remote_cols->[$_-1], @remote_col_ids;
dc379dc6	295
c4a69b87	296	next REL if (any { not defined $_ } @local_cols)
c4a69b87	297	\|\| (any { not defined $_ } @remote_cols);
dc379dc6	298
	299	push @rels, {
	300	local_columns => \@local_cols,
dc379dc6	301	remote_table => $remote_table,
c4a69b87	302	remote_columns => \@remote_cols,
dc379dc6	303	};
c4a69b87	304	};
0852b7b8	305
	306	return \@rels;
	307	}
	308
fe67d343	309	sub _table_uniq_info {
	310	my ($self, $table) = @_;
	311
c4a69b87	312	my $db = $table->database;
	313	my $owner = $table->schema;
	314	my $uid = $self->_uid($db, $owner);
	315
	316	my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');
	317
	318	$self->dbh->do("USE [$db]");
	319
	320	my $sth = $self->dbh->prepare(<<"EOF");
	321	SELECT si.name, si.indid, si.keycnt
	322	FROM [$db].dbo.sysindexes si
	323	JOIN [$db].dbo.sysobjects so
	324	ON si.id = so.id
	325	WHERE so.name = @{[ $self->dbh->quote($table->name) ]}
	326	AND so.uid = $uid
	327	AND si.indid > 0
	328	AND si.status & 2048 <> 2048
	329	AND si.status2 & 2 = 2
	330	EOF
	331	$sth->execute;
0852b7b8	332
c4a69b87	333	my %uniqs;
fe67d343	334
c4a69b87	335	while (my ($ind_name, $ind_id, $key_cnt) = $sth->fetchrow_array) {
	336	COLS: foreach my $col_idx (1 .. ($key_cnt+1)) {
	337	my ($next_col) = $self->dbh->selectrow_array(<<"EOF");
	338	SELECT index_col(
	339	@{[ $self->dbh->quote($table->name) ]},
	340	$ind_id, $col_idx, $uid
	341	)
	342	EOF
	343	last COLS unless defined $next_col;
	344
	345	push @{ $uniqs{$ind_name} }, $next_col;
fe67d343	346	}
	347	}
	348
c4a69b87	349	$self->dbh->do("USE [$current_db]");
c4a69b87	350
6c4f5a4a	351	return [ map { [ $_ => $uniqs{$_} ] } sort keys %uniqs ];
fe67d343	352	}
fe67d343	353
db4d62ad	354	sub _columns_info_for {
	355	my $self = shift;
	356	my ($table) = @_;
	357	my $result = $self->next::method(@_);
	358
c4a69b87	359	my $db = $table->database;
	360	my $owner = $table->schema;
	361	my $uid = $self->_uid($db, $owner);
	362
	363	local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
	364	my $sth = $self->dbh->prepare(<<"EOF");
006c8ed3	365	SELECT c.name, bt.name base_type, ut.name user_type, c.prec prec, c.scale scale, c.length len, c.cdefault dflt_id, c.computedcol comp_id, (c.status & 0x80) is_id
c4a69b87	366	FROM [$db].dbo.syscolumns c
006c8ed3	367	LEFT JOIN [$db].dbo.sysobjects o ON c.id = o.id
	368	LEFT JOIN [$db].dbo.systypes bt ON c.type = bt.type
	369	LEFT JOIN [$db].dbo.systypes ut ON c.usertype = ut.usertype
c4a69b87	370	WHERE o.name = @{[ $self->dbh->quote($table) ]}
	371	AND o.uid = $uid
	372	AND o.type IN ('U', 'V')
	373	EOF
db4d62ad	374	$sth->execute;
2fb9a4b3	375	my $info = $sth->fetchall_hashref('name');
db4d62ad	376
2fb9a4b3	377	while (my ($col, $res) = each %$result) {
006c8ed3	378	$res->{data_type} = $info->{$col}{user_type} \|\| $info->{$col}{base_type};
c4a69b87	379
006c8ed3	380	if ($info->{$col}{is_id}) {
c4a69b87	381	$res->{is_auto_increment} = 1;
c4a69b87	382	}
e17ad40a	383	$sth->finish;
41968729	384
006c8ed3	385	# column has default value
	386	if (my $default_id = $info->{$col}{dflt_id}) {
	387	my $sth = $self->dbh->prepare(<<"EOF");
	388	SELECT cm.id, cm.text
	389	FROM [$db].dbo.syscomments cm
	390	WHERE cm.id = $default_id
	391	EOF
	392	$sth->execute;
	393
	394	if (my ($d_id, $default) = $sth->fetchrow_array) {
	395	my $constant_default = ($default =~ /^DEFAULT \s+ (\S.*\S)/ix)
	396	? $1
	397	: $default;
	398
	399	$constant_default = substr($constant_default, 1, length($constant_default) - 2)
	400	if ( substr($constant_default, 0, 1) =~ m{['"\[]}
	401	&& substr($constant_default, -1) =~ m{['"\]]});
	402
	403	$res->{default_value} = $constant_default;
	404	}
41968729	405	}
2fb9a4b3	406
006c8ed3	407	# column is a computed value
	408	if (my $comp_id = $info->{$col}{comp_id}) {
	409	my $sth = $self->dbh->prepare(<<"EOF");
	410	SELECT cm.id, cm.text
	411	FROM [$db].dbo.syscomments cm
	412	WHERE cm.id = $comp_id
	413	EOF
	414	$sth->execute;
	415	if (my ($c_id, $comp) = $sth->fetchrow_array) {
	416	my $function = ($comp =~ /^AS \s+ (\S+)/ix) ? $1 : $comp;
2fb9a4b3	417	$res->{default_value} = \$function;
0faae4b8	418
	419	if ($function =~ /^getdate\b/) {
	420	$res->{inflate_datetime} = 1;
	421	}
5163dc4a	422
	423	delete $res->{size};
	424	$res->{data_type} = undef;
2fb9a4b3	425	}
2fb9a4b3	426	}
6ecee584	427
6ecee584	428	if (my $data_type = $res->{data_type}) {
5163dc4a	429	if ($data_type eq 'int') {
	430	$data_type = $res->{data_type} = 'integer';
	431	}
	432	elsif ($data_type eq 'decimal') {
	433	$data_type = $res->{data_type} = 'numeric';
	434	}
006c8ed3	435	elsif ($data_type eq 'float') {
	436	$data_type = $res->{data_type}
	437	= ($info->{$col}{len} <= 4 ? 'real' : 'double precision');
	438	}
	439
	440	if ($data_type eq 'timestamp') {
	441	$res->{inflate_datetime} = 0;
	442	}
5163dc4a	443
5163dc4a	444	if ($data_type =~ /^(?:text\|unitext\|image\|bigint\|integer\|smallint\|tinyint\|real\|double\|double precision\|float\|date\|time\|datetime\|smalldatetime\|money\|smallmoney\|timestamp\|bit)\z/i) {
6ecee584	445	delete $res->{size};
6ecee584	446	}
5163dc4a	447	elsif ($data_type eq 'numeric') {
	448	my ($prec, $scale) = @{$info->{$col}}{qw/prec scale/};
	449
006c8ed3	450	if (!defined $prec && !defined $scale) {
	451	$data_type = $res->{data_type} = 'integer';
	452	delete $res->{size};
	453	}
	454	elsif ($prec == 18 && $scale == 0) {
5163dc4a	455	delete $res->{size};
	456	}
	457	else {
	458	$res->{size} = [ $prec, $scale ];
	459	}
6ecee584	460	}
c4a69b87	461	elsif ($data_type =~ /char/) {
	462	$res->{size} = $info->{$col}{len};
	463
	464	if ($data_type =~ /^(?:unichar\|univarchar)\z/i) {
	465	$res->{size} /= 2;
	466	}
e17ad40a	467	elsif ($data_type =~ /^n(?:var)?char\z/i) {
	468	my ($nchar_size) = $self->dbh->selectrow_array('SELECT @@ncharsize');
	469
	470	$res->{size} /= $nchar_size;
	471	}
6ecee584	472	}
6ecee584	473	}
db4d62ad	474	}
	475
	476	return $result;
	477	}
	478
fe67d343	479	=head1 SEE ALSO
fe67d343	480
5163dc4a	481	L<DBIx::Class::Schema::Loader::DBI::Sybase::Common>,
fe67d343	482	L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
	483	L<DBIx::Class::Schema::Loader::DBI>
	484
b87ab391	485	=head1 AUTHORS
fe67d343	486
b87ab391	487	See L<DBIx::Class::Schema::Loader/AUTHORS>.
fe67d343	488
be80bba7	489	=head1 LICENSE
0852b7b8	490
be80bba7	491	This library is free software; you can redistribute it and/or modify it under
be80bba7	492	the same terms as Perl itself.
0852b7b8	493
fe67d343	494	=cut
	495
	496	1;
db9c411a	497	# vim:et sts=4 sw=4 tw=0: