X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FDBI%2FSybase.pm;h=60657d5cf4997efabb3a940c1bfc60d46d98396e;hb=1bcb47d3c20055e9c5d9fe522b3ddd1a7f1bbec9;hp=995c561d7e0fd36c621fba8c32a0da299f2bb234;hpb=1e1839d194d3713344fa716408b4fcf351396b48;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 995c561..60657d5 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/Sybase.pm @@ -2,11 +2,14 @@ package DBIx::Class::Schema::Loader::DBI::Sybase; use strict; use warnings; -use base 'DBIx::Class::Schema::Loader::DBI'; +use base qw/ + DBIx::Class::Schema::Loader::DBI + DBIx::Class::Schema::Loader::DBI::Sybase::Common +/; use Carp::Clan qw/^DBIx::Class/; use Class::C3; -our $VERSION = '0.04999_06'; +our $VERSION = '0.04999_08'; =head1 NAME @@ -27,11 +30,14 @@ See L. =cut +sub _is_case_sensitive { 1 } + sub _setup { my $self = shift; $self->next::method(@_); - $self->{db_schema} ||= 'dbo'; + $self->{db_schema} ||= $self->_build_db_schema; + $self->_set_quote_char_and_name_sep; } sub _rebless { @@ -40,17 +46,12 @@ sub _rebless { 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) { - my $subclass = 'DBIx::Class::Schema::Loader::DBI::MSSQL'; + $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; } - } else { - $self->schema->storage->sql_maker->quote_char([qw/[ ]/]) - unless $self->schema->storage->sql_maker->quote_char; - - $self->schema->storage->sql_maker->name_sep('.') - unless $self->schema->storage->sql_maker->name_sep; } } @@ -73,7 +74,7 @@ sub _table_pk_info { my @keydata; while (my $row = $sth->fetchrow_hashref) { - push @keydata, lc $row->{column_name}; + push @keydata, $row->{column_name}; } return \@keydata; @@ -82,19 +83,45 @@ sub _table_pk_info { 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 = '$table'}); + $sth->execute; + my $row = $sth->fetchrow_hashref; + + return unless $row; + + if (exists $row->{fk_name}) { + $sth->finish; + return $self->_table_fk_info_by_name($table); + } + + $sth->finish; + return $self->_table_fk_info_builder($table); +} + +sub _table_fk_info_by_name { + 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 - $dbh->{syb_err_handler} = sub { return 0 if $_[0] == 17461; }; - my $sth = $dbh->prepare(qq{sp_fkeys \@FKTABLE_NAME = '$table'}); + local $dbh->{syb_err_handler} = sub { return $_[0] == 17461 ? 0 : 1 }; + my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = '$table'}); $sth->execute; while (my $row = $sth->fetchrow_hashref) { - next unless $row->{FK_NAME}; - my $fk = $row->{FK_NAME}; - push @{$local_cols->{$fk}}, lc $row->{FKCOLUMN_NAME}; - push @{$remote_cols->{$fk}}, lc $row->{PKCOLUMN_NAME}; - $remote_table->{$fk} = $row->{PKTABLE_NAME}; + my $fk = $row->{fk_name}; + next unless defined $fk; + + push @{$local_cols->{$fk}}, $row->{fkcolumn_name}; + push @{$remote_cols->{$fk}}, $row->{pkcolumn_name}; + $remote_table->{$fk} = $row->{pktable_name}; } foreach my $fk (keys %$remote_table) { @@ -108,29 +135,90 @@ sub _table_fk_info { return \@rels; } +sub _table_fk_info_builder { + 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 = '$table'}); + $sth->execute; + + my @fk_info; + while (my $row = $sth->fetchrow_hashref) { + (my $ksq = $row->{key_seq}) =~ s/\s+//g; + + my @keys = qw/pktable_name pkcolumn_name fktable_name fkcolumn_name/; + my %ds; + @ds{@keys} = @{$row}{@keys}; + $ds{key_seq} = $ksq; + + push @{ $fk_info[$ksq] }, \%ds; + } + + 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 + ]; + } + + while (1) { + my @rel = map shift @$_, @level_rels[1..$level]; + + last unless defined $rel[0]; + + my @local_columns = map $_->{fkcolumn_name}, @rel; + my @remote_columns = map $_->{pkcolumn_name}, @rel; + my $remote_table = $rel[0]->{pktable_name}; + + push @rels, { + local_columns => \@local_columns, + remote_columns => \@remote_columns, + remote_table => $remote_table + }; + } + } + + return \@rels; +} + sub _table_uniq_info { my ($self, $table) = @_; + local $SIG{__WARN__} = sub {}; + my $dbh = $self->schema->storage->dbh; + local $dbh->{FetchHashKeyName} = 'NAME_lc'; my $sth = $dbh->prepare(qq{sp_helpconstraint \@objname='$table', \@nomsg='nomsg'}); - $sth->execute; + eval { $sth->execute }; + return if $@; my $constraints; while (my $row = $sth->fetchrow_hashref) { if (exists $row->{constraint_type}) { my $type = $row->{constraint_type} || ''; if ($type =~ /^unique/i) { - my $name = lc $row->{constraint_name}; + my $name = $row->{constraint_name}; push @{$constraints->{$name}}, - ( split /,/, lc $row->{constraint_keys} ); + ( split /,/, $row->{constraint_keys} ); } } else { my $def = $row->{definition} || next; next unless $def =~ /^unique/i; - my $name = lc $row->{name}; + my $name = $row->{name}; my ($keys) = $def =~ /\((.*)\)/; $keys =~ s/\s*//g; - my @keys = map lc, split /,/ => $keys; + my @keys = split /,/ => $keys; push @{$constraints->{$name}}, @keys; } } @@ -165,6 +253,10 @@ L Justin Hunter C +=head1 CONTRIBUTORS + +Rafael Kitover + =cut 1;