use strict;
use warnings;
-use base qw/
- DBIx::Class::Schema::Loader::DBI
- DBIx::Class::Schema::Loader::DBI::Sybase::Common
-/;
-use Carp::Clan qw/^DBIx::Class/;
-use Class::C3;
+use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common';
+use mro 'c3';
+use List::Util 'any';
+use namespace::clean;
-our $VERSION = '0.04999_12';
+use DBIx::Class::Schema::Loader::Table::Sybase ();
-=head1 NAME
-
-DBIx::Class::Schema::Loader::DBI::Sybase - DBIx::Class::Schema::Loader::DBI Sybase Implementation.
-
-=head1 SYNOPSIS
-
- package My::Schema;
- use base qw/DBIx::Class::Schema::Loader/;
+our $VERSION = '0.07047';
- __PACKAGE__->loader_options( debug => 1 );
+=head1 NAME
- 1;
+DBIx::Class::Schema::Loader::DBI::Sybase - DBIx::Class::Schema::Loader::DBI
+Sybase ASE Implementation.
=head1 DESCRIPTION
-See L<DBIx::Class::Schema::Loader::Base>.
-
-=cut
-
-sub _is_case_sensitive { 1 }
+See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
-sub _setup {
- my $self = shift;
+This class reblesses into the L<DBIx::Class::Schema::Loader::DBI::Sybase::Microsoft_SQL_Server> class for connections to MSSQL.
- $self->next::method(@_);
- $self->{db_schema} ||= $self->_build_db_schema;
- $self->_set_quote_char_and_name_sep;
-}
+=cut
sub _rebless {
my $self = shift;
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 $dbh = $self->schema->storage->dbh;
- my $columns = $dbh->selectcol_arrayref(qq{SELECT name FROM syscolumns WHERE id = (SELECT id FROM sysobjects WHERE name = @{[ $dbh->quote($table) ]} AND type = 'U')});
+ 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 $dbh = $self->schema->storage->dbh;
- my $sth = $dbh->prepare(qq{sp_pkeys @{[ $dbh->quote($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;
push @keydata, $row->{column_name};
}
+ $self->dbh->do("USE [$current_db]");
+
return \@keydata;
}
sub _table_fk_info {
my ($self, $table) = @_;
- # check if FK_NAME is supported
-
- my $dbh = $self->schema->storage->dbh;
- local $dbh->{FetchHashKeyName} = 'NAME_lc';
- # hide "Object does not exist in this database." when trying to fetch fkeys
- local $dbh->{syb_err_handler} = sub { return $_[0] == 17461 ? 0 : 1 };
- my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($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 $row = $sth->fetchrow_hashref;
- return unless $row;
+ my @rels;
- if (exists $row->{fk_name}) {
- $sth->finish;
- return $self->_table_fk_info_by_name($table);
- }
+ REL: while (my @rel = $sth->fetchrow_array) {
+ my ($remote_tab_id, $remote_db, $key_cnt) = splice @rel, 0, 3;
- $sth->finish;
- return $self->_table_fk_info_builder($table);
-}
+ 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
-sub _table_fk_info_by_name {
- my ($self, $table) = @_;
- my ($local_cols, $remote_cols, $remote_table, @rels);
+ next REL
+ unless any { $_ eq $remote_tab_owner }
+ @{ $self->db_schema->{$remote_db} || [] };
- my $dbh = $self->schema->storage->dbh;
- local $dbh->{FetchHashKeyName} = 'NAME_lc';
- # hide "Object does not exist in this database." when trying to fetch fkeys
- local $dbh->{syb_err_handler} = sub { return $_[0] == 17461 ? 0 : 1 };
- my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($table) ]}});
- $sth->execute;
+ my @local_col_ids = splice @rel, 0, 16;
+ my @remote_col_ids = splice @rel, 0, 16;
- while (my $row = $sth->fetchrow_hashref) {
- my $fk = $row->{fk_name};
- next unless defined $fk;
+ @local_col_ids = splice @local_col_ids, 0, $key_cnt;
+ @remote_col_ids = splice @remote_col_ids, 0, $key_cnt;
- push @{$local_cols->{$fk}}, $row->{fkcolumn_name};
- push @{$remote_cols->{$fk}}, $row->{pkcolumn_name};
- $remote_table->{$fk} = $row->{pktable_name};
- }
+ 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);
- foreach my $fk (keys %$remote_table) {
push @rels, {
- local_columns => \@{$local_cols->{$fk}},
- remote_columns => \@{$remote_cols->{$fk}},
- remote_table => $remote_table->{$fk},
- };
+ local_columns => \@local_cols,
+ remote_table => $remote_table,
+ remote_columns => \@remote_cols,
+ };
+ };
- }
return \@rels;
}
-sub _table_fk_info_builder {
+sub _table_uniq_info {
my ($self, $table) = @_;
- my $dbh = $self->schema->storage->dbh;
- local $dbh->{FetchHashKeyName} = 'NAME_lc';
- # hide "Object does not exist in this database." when trying to fetch fkeys
- local $dbh->{syb_err_handler} = sub { return 0 if $_[0] == 17461; };
- my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($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 @fk_info;
- while (my $row = $sth->fetchrow_hashref) {
- (my $ksq = $row->{key_seq}) =~ s/\s+//g;
+ my %uniqs;
- my @keys = qw/pktable_name pkcolumn_name fktable_name fkcolumn_name/;
- my %ds;
- @ds{@keys} = @{$row}{@keys};
- $ds{key_seq} = $ksq;
+ 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 @{ $fk_info[$ksq] }, \%ds;
+ push @{ $uniqs{$ind_name} }, $next_col;
+ }
}
- my $max_keys = $#fk_info;
- my @rels;
- for my $level (reverse 1 .. $max_keys) {
- my @level_rels;
- $level_rels[$level] = splice @fk_info, $level, 1;
- my $count = @{ $level_rels[$level] };
-
- for my $sub_level (reverse 1 .. $level-1) {
- my $total = @{ $fk_info[$sub_level] };
-
- $level_rels[$sub_level] = [
- splice @{ $fk_info[$sub_level] }, $total-$count, $count
- ];
- }
+ $self->dbh->do("USE [$current_db]");
- while (1) {
- my @rel = map shift @$_, @level_rels[1..$level];
+ return [ map { [ $_ => $uniqs{$_} ] } sort keys %uniqs ];
+}
- last unless defined $rel[0];
+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');
- my @local_columns = map $_->{fkcolumn_name}, @rel;
- my @remote_columns = map $_->{pkcolumn_name}, @rel;
- my $remote_table = $rel[0]->{pktable_name};
+ while (my ($col, $res) = each %$result) {
+ $res->{data_type} = $info->{$col}{user_type} || $info->{$col}{base_type};
- push @rels, {
- local_columns => \@local_columns,
- remote_columns => \@remote_columns,
- remote_table => $remote_table
- };
+ if ($info->{$col}{is_id}) {
+ $res->{is_auto_increment} = 1;
}
- }
-
- return \@rels;
-}
-
-sub _table_uniq_info {
- my ($self, $table) = @_;
-
- local $SIG{__WARN__} = sub {};
+ $sth->finish;
- my $dbh = $self->schema->storage->dbh;
- local $dbh->{FetchHashKeyName} = 'NAME_lc';
- my $sth = $dbh->prepare(qq{sp_helpconstraint \@objname=@{[ $dbh->quote($table) ]}, \@nomsg='nomsg'});
- eval { $sth->execute };
- return if $@;
+ # 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;
+ }
+ }
- my $constraints;
- while (my $row = $sth->fetchrow_hashref) {
- if (exists $row->{constraint_type}) {
- my $type = $row->{constraint_type} || '';
- if ($type =~ /^unique/i) {
- my $name = $row->{constraint_name};
- push @{$constraints->{$name}},
- ( split /,/, $row->{constraint_keys} );
+ # 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;
}
- } else {
- my $def = $row->{definition} || next;
- next unless $def =~ /^unique/i;
- my $name = $row->{name};
- my ($keys) = $def =~ /\((.*)\)/;
- $keys =~ s/\s*//g;
- my @keys = split /,/ => $keys;
- push @{$constraints->{$name}}, @keys;
}
- }
- my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
- return \@uniqs;
-}
+ 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');
+ }
-sub _extra_column_info {
- my ($self, $info) = @_;
- my %extra_info;
+ if ($data_type eq 'timestamp') {
+ $res->{inflate_datetime} = 0;
+ }
- my ($table, $column) = @$info{qw/TABLE_NAME COLUMN_NAME/};
+ 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};
- my $dbh = $self->schema->storage->dbh;
- my $sth = $dbh->prepare(qq{SELECT name FROM syscolumns WHERE id = (SELECT id FROM sysobjects WHERE name = @{[ $dbh->quote($table) ]}) AND (status & 0x80) = 0x80 AND name = @{[ $dbh->quote($column) ]}});
- $sth->execute();
+ 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');
- if ($sth->fetchrow_array) {
- $extra_info{is_auto_increment} = 1;
+ $res->{size} /= $nchar_size;
+ }
+ }
+ }
}
- return \%extra_info;
+ 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
+=head1 AUTHORS
-See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+See L<DBIx::Class::Schema::Loader/AUTHORS>.
=head1 LICENSE
=cut
1;
+# vim:et sts=4 sw=4 tw=0:
projects / dbsrgits/DBIx-Class-Schema-Loader.git / blobdiff