new dev release
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / DBI / Sybase.pm
CommitLineData
fe67d343 1package DBIx::Class::Schema::Loader::DBI::Sybase;
2
3use strict;
4use warnings;
c9373b79 5use base qw/
6 DBIx::Class::Schema::Loader::DBI
7 DBIx::Class::Schema::Loader::DBI::Sybase::Common
8/;
fe67d343 9use Carp::Clan qw/^DBIx::Class/;
10use Class::C3;
11
0a701ff3 12our $VERSION = '0.04999_12';
fe67d343 13
14=head1 NAME
15
16DBIx::Class::Schema::Loader::DBI::Sybase - DBIx::Class::Schema::Loader::DBI Sybase Implementation.
17
18=head1 SYNOPSIS
19
20 package My::Schema;
21 use base qw/DBIx::Class::Schema::Loader/;
22
23 __PACKAGE__->loader_options( debug => 1 );
24
25 1;
26
27=head1 DESCRIPTION
28
29See L<DBIx::Class::Schema::Loader::Base>.
30
31=cut
32
565335e6 33sub _is_case_sensitive { 1 }
34
fe67d343 35sub _setup {
36 my $self = shift;
37
38 $self->next::method(@_);
c9373b79 39 $self->{db_schema} ||= $self->_build_db_schema;
40 $self->_set_quote_char_and_name_sep;
fe67d343 41}
42
43sub _rebless {
44 my $self = shift;
45
46 my $dbh = $self->schema->storage->dbh;
47 my $DBMS_VERSION = @{$dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2];
48 if ($DBMS_VERSION =~ /^Microsoft /i) {
b1e43108 49 $DBMS_VERSION =~ s/\s/_/g;
50 my $subclass = "DBIx::Class::Schema::Loader::DBI::Sybase::$DBMS_VERSION";
65f74457 51 if ($self->load_optional_class($subclass) && !$self->isa($subclass)) {
52 bless $self, $subclass;
53 $self->_rebless;
fe67d343 54 }
55 }
56}
57
58sub _table_columns {
59 my ($self, $table) = @_;
60
61 my $dbh = $self->schema->storage->dbh;
772367d3 62 my $columns = $dbh->selectcol_arrayref(qq{SELECT name FROM syscolumns WHERE id = (SELECT id FROM sysobjects WHERE name = @{[ $dbh->quote($table) ]} AND type = 'U')});
fe67d343 63
64 return $columns;
65}
66
67sub _table_pk_info {
68 my ($self, $table) = @_;
69
70 my $dbh = $self->schema->storage->dbh;
772367d3 71 my $sth = $dbh->prepare(qq{sp_pkeys @{[ $dbh->quote($table) ]}});
fe67d343 72 $sth->execute;
73
74 my @keydata;
75
76 while (my $row = $sth->fetchrow_hashref) {
c9373b79 77 push @keydata, $row->{column_name};
fe67d343 78 }
79
80 return \@keydata;
81}
82
83sub _table_fk_info {
84 my ($self, $table) = @_;
85
0852b7b8 86 # check if FK_NAME is supported
565335e6 87
0852b7b8 88 my $dbh = $self->schema->storage->dbh;
565335e6 89 local $dbh->{FetchHashKeyName} = 'NAME_lc';
0852b7b8 90 # hide "Object does not exist in this database." when trying to fetch fkeys
91 local $dbh->{syb_err_handler} = sub { return $_[0] == 17461 ? 0 : 1 };
772367d3 92 my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($table) ]}});
0852b7b8 93 $sth->execute;
94 my $row = $sth->fetchrow_hashref;
95
96 return unless $row;
97
98 if (exists $row->{fk_name}) {
99 $sth->finish;
100 return $self->_table_fk_info_by_name($table);
101 }
102
103 $sth->finish;
104 return $self->_table_fk_info_builder($table);
105}
106
107sub _table_fk_info_by_name {
108 my ($self, $table) = @_;
109 my ($local_cols, $remote_cols, $remote_table, @rels);
565335e6 110
0852b7b8 111 my $dbh = $self->schema->storage->dbh;
112 local $dbh->{FetchHashKeyName} = 'NAME_lc';
fe67d343 113 # hide "Object does not exist in this database." when trying to fetch fkeys
0852b7b8 114 local $dbh->{syb_err_handler} = sub { return $_[0] == 17461 ? 0 : 1 };
772367d3 115 my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($table) ]}});
fe67d343 116 $sth->execute;
117
118 while (my $row = $sth->fetchrow_hashref) {
0852b7b8 119 my $fk = $row->{fk_name};
120 next unless defined $fk;
565335e6 121
122 push @{$local_cols->{$fk}}, $row->{fkcolumn_name};
123 push @{$remote_cols->{$fk}}, $row->{pkcolumn_name};
124 $remote_table->{$fk} = $row->{pktable_name};
fe67d343 125 }
126
127 foreach my $fk (keys %$remote_table) {
65f74457 128 push @rels, {
129 local_columns => \@{$local_cols->{$fk}},
130 remote_columns => \@{$remote_cols->{$fk}},
131 remote_table => $remote_table->{$fk},
132 };
fe67d343 133
134 }
135 return \@rels;
136}
137
0852b7b8 138sub _table_fk_info_builder {
139 my ($self, $table) = @_;
140
141 my $dbh = $self->schema->storage->dbh;
142 local $dbh->{FetchHashKeyName} = 'NAME_lc';
143 # hide "Object does not exist in this database." when trying to fetch fkeys
144 local $dbh->{syb_err_handler} = sub { return 0 if $_[0] == 17461; };
772367d3 145 my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($table) ]}});
0852b7b8 146 $sth->execute;
147
148 my @fk_info;
149 while (my $row = $sth->fetchrow_hashref) {
150 (my $ksq = $row->{key_seq}) =~ s/\s+//g;
151
152 my @keys = qw/pktable_name pkcolumn_name fktable_name fkcolumn_name/;
153 my %ds;
154 @ds{@keys} = @{$row}{@keys};
155 $ds{key_seq} = $ksq;
156
157 push @{ $fk_info[$ksq] }, \%ds;
158 }
159
160 my $max_keys = $#fk_info;
161 my @rels;
162 for my $level (reverse 1 .. $max_keys) {
163 my @level_rels;
164 $level_rels[$level] = splice @fk_info, $level, 1;
165 my $count = @{ $level_rels[$level] };
166
167 for my $sub_level (reverse 1 .. $level-1) {
168 my $total = @{ $fk_info[$sub_level] };
169
170 $level_rels[$sub_level] = [
171 splice @{ $fk_info[$sub_level] }, $total-$count, $count
172 ];
173 }
174
175 while (1) {
176 my @rel = map shift @$_, @level_rels[1..$level];
177
178 last unless defined $rel[0];
179
180 my @local_columns = map $_->{fkcolumn_name}, @rel;
181 my @remote_columns = map $_->{pkcolumn_name}, @rel;
182 my $remote_table = $rel[0]->{pktable_name};
183
184 push @rels, {
185 local_columns => \@local_columns,
186 remote_columns => \@remote_columns,
187 remote_table => $remote_table
188 };
189 }
190 }
191
192 return \@rels;
193}
194
fe67d343 195sub _table_uniq_info {
196 my ($self, $table) = @_;
197
0852b7b8 198 local $SIG{__WARN__} = sub {};
199
fe67d343 200 my $dbh = $self->schema->storage->dbh;
0852b7b8 201 local $dbh->{FetchHashKeyName} = 'NAME_lc';
772367d3 202 my $sth = $dbh->prepare(qq{sp_helpconstraint \@objname=@{[ $dbh->quote($table) ]}, \@nomsg='nomsg'});
0852b7b8 203 eval { $sth->execute };
204 return if $@;
fe67d343 205
206 my $constraints;
207 while (my $row = $sth->fetchrow_hashref) {
1e1839d1 208 if (exists $row->{constraint_type}) {
209 my $type = $row->{constraint_type} || '';
210 if ($type =~ /^unique/i) {
c9373b79 211 my $name = $row->{constraint_name};
1e1839d1 212 push @{$constraints->{$name}},
c9373b79 213 ( split /,/, $row->{constraint_keys} );
1e1839d1 214 }
215 } else {
216 my $def = $row->{definition} || next;
217 next unless $def =~ /^unique/i;
c9373b79 218 my $name = $row->{name};
1e1839d1 219 my ($keys) = $def =~ /\((.*)\)/;
220 $keys =~ s/\s*//g;
c9373b79 221 my @keys = split /,/ => $keys;
1e1839d1 222 push @{$constraints->{$name}}, @keys;
fe67d343 223 }
224 }
225
226 my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
227 return \@uniqs;
228}
229
230sub _extra_column_info {
231 my ($self, $info) = @_;
232 my %extra_info;
233
234 my ($table, $column) = @$info{qw/TABLE_NAME COLUMN_NAME/};
235
236 my $dbh = $self->schema->storage->dbh;
772367d3 237 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) ]}});
fe67d343 238 $sth->execute();
239
240 if ($sth->fetchrow_array) {
241 $extra_info{is_auto_increment} = 1;
242 }
243
244 return \%extra_info;
245}
246
247=head1 SEE ALSO
248
249L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
250L<DBIx::Class::Schema::Loader::DBI>
251
252=head1 AUTHOR
253
be80bba7 254See L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
fe67d343 255
be80bba7 256=head1 LICENSE
0852b7b8 257
be80bba7 258This library is free software; you can redistribute it and/or modify it under
259the same terms as Perl itself.
0852b7b8 260
fe67d343 261=cut
262
2631;