X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FDBI%2FSybase.pm;h=94b1b684070e48af694b1c4018cdbc474731d125;hb=306bf770bf08b06f92863808b1938f2fc704acb0;hp=b044e5247898687de7174afbffc11cef7d62a618;hpb=c8845f2e67c636fbfb597a4562847cc80c4e5f28;p=dbsrgits%2FDBIx-Class-Schema-Loader.git diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm b/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm index b044e52..94b1b68 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm @@ -3,10 +3,13 @@ package DBIx::Class::Schema::Loader::DBI::Sybase; use strict; use warnings; use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common'; -use Carp::Clan qw/^DBIx::Class/; use mro 'c3'; +use List::Util 'any'; +use namespace::clean; -our $VERSION = '0.07009'; +use DBIx::Class::Schema::Loader::Table::Sybase (); + +our $VERSION = '0.07047'; =head1 NAME @@ -17,17 +20,9 @@ Sybase ASE Implementation. See L and L. -=cut - -sub _setup { - my $self = shift; +This class reblesses into the L class for connections to MSSQL. - $self->next::method(@_); - - if (not defined $self->preserve_case) { - $self->preserve_case(1); - } -} +=cut sub _rebless { my $self = shift; @@ -40,233 +35,385 @@ sub _rebless { if ($self->load_optional_class($subclass) && !$self->isa($subclass)) { bless $self, $subclass; $self->_rebless; - } + } } } -sub _tables_list { - my ($self, $opts) = @_; +sub _system_databases { + return (qw/ + master model sybsystemdb sybsystemprocs tempdb + /); +} - my $dbh = $self->schema->storage->dbh; +sub _system_tables { + return (qw/ + sysquerymetrics + /); +} - my $sth = $dbh->table_info(undef, $self->db_schema, undef, "'TABLE','VIEW'"); +sub _setup { + my $self = shift; - my @tables = grep $_ ne 'sysquerymetrics', - map $_->{table_name}, @{ $sth->fetchall_arrayref({ table_name => 1 }) }; + $self->next::method(@_); - return $self->_filter_tables(\@tables, $opts); -} + $self->preserve_case(1); -sub _table_columns { - my ($self, $table) = @_; + my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()'); - my $dbh = $self->schema->storage->dbh; - my $columns = $dbh->selectcol_arrayref(qq{ -SELECT c.name -FROM syscolumns c JOIN sysobjects o -ON c.id = o.id -WHERE o.name = @{[ $dbh->quote($table) ]} AND o.type = 'U' -}); + if (ref $self->db_schema eq 'HASH') { + if (keys %{ $self->db_schema } < 2) { + my ($db) = keys %{ $self->db_schema }; - return $columns; -} + $db ||= $current_db; -sub _table_pk_info { - my ($self, $table) = @_; + if ($db eq '%') { + my $owners = $self->db_schema->{$db}; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(qq{sp_pkeys @{[ $dbh->quote($table) ]}}); - $sth->execute; + my $db_names = $self->dbh->selectcol_arrayref(<<'EOF'); +SELECT name +FROM master.dbo.sysdatabases +EOF - my @keydata; + my @dbs; - while (my $row = $sth->fetchrow_hashref) { - push @keydata, $row->{column_name}; + 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()') ]; - return \@keydata; + $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 _table_fk_info { - my ($self, $table) = @_; +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, + ); + } + } + } - # check if FK_NAME is supported + return $self->_filter_tables(\@tables); +} - 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 $row = $sth->fetchrow_hashref; +sub _uid { + my ($self, $db, $owner) = @_; - return unless $row; + my ($uid) = $self->dbh->selectrow_array(<<"EOF"); +SELECT uid +FROM [$db].dbo.sysusers +WHERE name = @{[ $self->dbh->quote($owner) ]} +EOF - if (exists $row->{fk_name}) { - $sth->finish; - return $self->_table_fk_info_by_name($table); - } + 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 - $sth->finish; - return $self->_table_fk_info_builder($table); + return $columns; } -sub _table_fk_info_by_name { +sub _table_pk_info { my ($self, $table) = @_; - my ($local_cols, $remote_cols, $remote_table, @rels); - 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 ($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; - while (my $row = $sth->fetchrow_hashref) { - my $fk = $row->{fk_name}; - next unless defined $fk; + my @keydata; - push @{$local_cols->{$fk}}, $row->{fkcolumn_name}; - push @{$remote_cols->{$fk}}, $row->{pkcolumn_name}; - $remote_table->{$fk} = $row->{pktable_name}; + while (my $row = $sth->fetchrow_hashref) { + push @keydata, $row->{column_name}; } - foreach my $fk (keys %$remote_table) { - push @rels, { - local_columns => \@{$local_cols->{$fk}}, - remote_columns => \@{$remote_cols->{$fk}}, - remote_table => $remote_table->{$fk}, - }; + $self->dbh->do("USE [$current_db]"); - } - return \@rels; + return \@keydata; } -sub _table_fk_info_builder { +sub _table_fk_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 $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 @fk_info; - while (my $row = $sth->fetchrow_hashref) { - (my $ksq = $row->{key_seq}) =~ s/\s+//g; + my @rels; - my @keys = qw/pktable_name pkcolumn_name fktable_name fkcolumn_name/; - my %ds; - @ds{@keys} = @{$row}{@keys}; - $ds{key_seq} = $ksq; + REL: while (my @rel = $sth->fetchrow_array) { + my ($remote_tab_id, $remote_db, $key_cnt) = splice @rel, 0, 3; - push @{ $fk_info[$ksq] }, \%ds; - } + 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 - 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] }; + next REL + unless any { $_ eq $remote_tab_owner } + @{ $self->db_schema->{$remote_db} || [] }; - for my $sub_level (reverse 1 .. $level-1) { - my $total = @{ $fk_info[$sub_level] }; + my @local_col_ids = splice @rel, 0, 16; + my @remote_col_ids = splice @rel, 0, 16; - $level_rels[$sub_level] = [ - splice @{ $fk_info[$sub_level] }, $total-$count, $count - ]; - } + @local_col_ids = splice @local_col_ids, 0, $key_cnt; + @remote_col_ids = splice @remote_col_ids, 0, $key_cnt; - while (1) { - my @rel = map shift @$_, @level_rels[1..$level]; + my $remote_table = DBIx::Class::Schema::Loader::Table::Sybase->new( + loader => $self, + name => $remote_tab_name, + database => $remote_db, + schema => $remote_tab_owner, + ); - last unless defined $rel[0]; + my $all_local_cols = $self->_table_columns($table); + my $all_remote_cols = $self->_table_columns($remote_table); - my @local_columns = map $_->{fkcolumn_name}, @rel; - my @remote_columns = map $_->{pkcolumn_name}, @rel; - my $remote_table = $rel[0]->{pktable_name}; + my @local_cols = map $all_local_cols->[$_-1], @local_col_ids; + my @remote_cols = map $all_remote_cols->[$_-1], @remote_col_ids; - push @rels, { - local_columns => \@local_columns, - remote_columns => \@remote_columns, - remote_table => $remote_table - }; - } - } + 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 { - no warnings 'uninitialized'; # for presumably XS weirdness with null operations my ($self, $table) = @_; - local $SIG{__WARN__} = sub { warn @_ - unless $_[0] =~ /^Formula for Calculation:|^(?:--?|\+|=) Number of (?:self )?references|^Total Number of Referential Constraints|^Details:|^\s*$/ }; + 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 $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 $@; + my %uniqs; - 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} ); - } - } 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; + 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 { [ $_ => $constraints->{$_} ] } keys %$constraints; - return \@uniqs; + $self->dbh->do("USE [$current_db]"); + + return [ map { [ $_ => $uniqs{$_} ] } sort keys %uniqs ]; } -# get the correct data types, defaults and size sub _columns_info_for { my $self = shift; my ($table) = @_; my $result = $self->next::method(@_); - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(qq{ -SELECT c.name name, bt.name base_type, ut.name user_type, cm.text deflt, c.prec prec, c.scale scale, c.length len -FROM syscolumns c -JOIN sysobjects o ON c.id = o.id -LEFT JOIN systypes bt ON c.type = bt.type -LEFT JOIN systypes ut ON c.usertype = ut.usertype -LEFT JOIN syscomments cm - ON cm.id = CASE WHEN c.cdefault = 0 THEN c.computedcol ELSE c.cdefault END -WHERE o.name = @{[ $dbh->quote($table) ]} AND o.type = 'U' -}); + 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; - local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $info = $sth->fetchall_hashref('name'); while (my ($col, $res) = each %$result) { - my $data_type = $res->{data_type} = $info->{$col}{user_type} || $info->{$col}{base_type}; + $res->{data_type} = $info->{$col}{user_type} || $info->{$col}{base_type}; - if ($data_type && $data_type =~ /^timestamp\z/i) { - $res->{inflate_datetime} = 0; + 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{['"\]]}); - if (my $default = $info->{$col}{deflt}) { - if ($default =~ /^AS \s+ (\S+)/ix) { - my $function = $1; + $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/) { @@ -276,10 +423,6 @@ WHERE o.name = @{[ $dbh->quote($table) ]} AND o.type = 'U' delete $res->{size}; $res->{data_type} = undef; } - elsif ($default =~ /^DEFAULT \s+ (\S+)/ix) { - my ($constant_default) = $1 =~ /^['"\[\]]?(.*?)['"\[\]]?\z/; - $res->{default_value} = $constant_default; - } } if (my $data_type = $res->{data_type}) { @@ -289,6 +432,14 @@ WHERE o.name = @{[ $dbh->quote($table) ]} AND o.type = 'U' 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}; @@ -296,50 +447,44 @@ WHERE o.name = @{[ $dbh->quote($table) ]} AND o.type = 'U' elsif ($data_type eq 'numeric') { my ($prec, $scale) = @{$info->{$col}}{qw/prec scale/}; - if ($prec == 18 && $scale == 0) { + 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 =~ /^(?:unichar|univarchar)\z/i) { - $res->{size} /= 2; - } - } + 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'); - if ($data_type eq 'float') { - $res->{data_type} = $info->{$col}{len} <= 4 ? 'real' : 'double precision'; + $res->{size} /= $nchar_size; + } + } } } return $result; } -sub _extra_column_info { - my ($self, $table, $column, $info, $dbi_info) = @_; - my %extra_info; - - 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 ($sth->fetchrow_array) { - $extra_info{is_auto_increment} = 1; - } - - return \%extra_info; -} - =head1 SEE ALSO L, L, L, L -=head1 AUTHOR +=head1 AUTHORS -See L and L. +See L. =head1 LICENSE