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::MoreUtils 'any';
use namespace::clean;
use DBIx::Class::Schema::Loader::Table::Sybase ();
our $VERSION = '0.07034_01';
=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, $opts) = @_;
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, $opts);
}
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;
}
}
my @uniqs = map { [ $_ => $uniqs{$_} ] } keys %uniqs;
$self->dbh->do("USE [$current_db]");
return \@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 AUTHOR
See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
=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: