1package DBIx::Class::Schema::Loader::DBI::Sybase; 2 3use strict; 4use warnings; 5use base 'DBIx::Class::Schema::Loader::DBI::Sybase::Common'; 6use Carp::Clan qw/^DBIx::Class/; 7use Class::C3; 8 9our $VERSION = '0.05003'; 10 11=head1 NAME 12 13DBIx::Class::Schema::Loader::DBI::Sybase - DBIx::Class::Schema::Loader::DBI Sybase Implementation. 14 15=head1 SYNOPSIS 16 17 package My::Schema; 18 use base qw/DBIx::Class::Schema::Loader/; 19 20 __PACKAGE__->loader_options( debug => 1 ); 21 22 1; 23 24=head1 DESCRIPTION 25 26See L<DBIx::Class::Schema::Loader::Base>. 27 28=cut 29 30sub _is_case_sensitive { 1 } 31 32sub _setup { 33 my $self = shift; 34 35 $self->next::method(@_); 36 $self->{db_schema} ||= $self->_build_db_schema; 37 $self->_set_quote_char_and_name_sep; 38} 39 40sub _rebless { 41 my $self = shift; 42 43 my $dbh = $self->schema->storage->dbh; 44 my $DBMS_VERSION = @{$dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]; 45 if ($DBMS_VERSION =~ /^Microsoft /i) { 46 $DBMS_VERSION =~ s/\s/_/g; 47 my $subclass = "DBIx::Class::Schema::Loader::DBI::Sybase::$DBMS_VERSION"; 48 if ($self->load_optional_class($subclass) && !$self->isa($subclass)) { 49 bless $self, $subclass; 50 $self->_rebless; 51 } 52 } 53} 54 55sub _table_columns { 56 my ($self, $table) = @_; 57 58 my $dbh = $self->schema->storage->dbh; 59 my $columns = $dbh->selectcol_arrayref(qq{ 60SELECT c.name 61FROM syscolumns c JOIN sysobjects o 62ON c.id = o.id 63WHERE o.name = @{[ $dbh->quote($table) ]} AND o.type = 'U' 64}); 65 66 return $columns; 67} 68 69sub _table_pk_info { 70 my ($self, $table) = @_; 71 72 my $dbh = $self->schema->storage->dbh; 73 my $sth = $dbh->prepare(qq{sp_pkeys @{[ $dbh->quote($table) ]}}); 74 $sth->execute; 75 76 my @keydata; 77 78 while (my $row = $sth->fetchrow_hashref) { 79 push @keydata, $row->{column_name}; 80 } 81 82 return \@keydata; 83} 84 85sub _table_fk_info { 86 my ($self, $table) = @_; 87 88 # check if FK_NAME is supported 89 90 my $dbh = $self->schema->storage->dbh; 91 local $dbh->{FetchHashKeyName} = 'NAME_lc'; 92 # hide "Object does not exist in this database." when trying to fetch fkeys 93 local $dbh->{syb_err_handler} = sub { return $_[0] == 17461 ? 0 : 1 }; 94 my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($table) ]}}); 95 $sth->execute; 96 my $row = $sth->fetchrow_hashref; 97 98 return unless $row; 99 100 if (exists $row->{fk_name}) { 101 $sth->finish; 102 return $self->_table_fk_info_by_name($table); 103 } 104 105 $sth->finish; 106 return $self->_table_fk_info_builder($table); 107} 108 109sub _table_fk_info_by_name { 110 my ($self, $table) = @_; 111 my ($local_cols, $remote_cols, $remote_table, @rels); 112 113 my $dbh = $self->schema->storage->dbh; 114 local $dbh->{FetchHashKeyName} = 'NAME_lc'; 115 # hide "Object does not exist in this database." when trying to fetch fkeys 116 local $dbh->{syb_err_handler} = sub { return $_[0] == 17461 ? 0 : 1 }; 117 my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($table) ]}}); 118 $sth->execute; 119 120 while (my $row = $sth->fetchrow_hashref) { 121 my $fk = $row->{fk_name}; 122 next unless defined $fk; 123 124 push @{$local_cols->{$fk}}, $row->{fkcolumn_name}; 125 push @{$remote_cols->{$fk}}, $row->{pkcolumn_name}; 126 $remote_table->{$fk} = $row->{pktable_name}; 127 } 128 129 foreach my $fk (keys %$remote_table) { 130 push @rels, { 131 local_columns => \@{$local_cols->{$fk}}, 132 remote_columns => \@{$remote_cols->{$fk}}, 133 remote_table => $remote_table->{$fk}, 134 }; 135 136 } 137 return \@rels; 138} 139 140sub _table_fk_info_builder { 141 my ($self, $table) = @_; 142 143 my $dbh = $self->schema->storage->dbh; 144 local $dbh->{FetchHashKeyName} = 'NAME_lc'; 145 # hide "Object does not exist in this database." when trying to fetch fkeys 146 local $dbh->{syb_err_handler} = sub { return 0 if $_[0] == 17461; }; 147 my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = @{[ $dbh->quote($table) ]}}); 148 $sth->execute; 149 150 my @fk_info; 151 while (my $row = $sth->fetchrow_hashref) { 152 (my $ksq = $row->{key_seq}) =~ s/\s+//g; 153 154 my @keys = qw/pktable_name pkcolumn_name fktable_name fkcolumn_name/; 155 my %ds; 156 @ds{@keys} = @{$row}{@keys}; 157 $ds{key_seq} = $ksq; 158 159 push @{ $fk_info[$ksq] }, \%ds; 160 } 161 162 my $max_keys = $#fk_info; 163 my @rels; 164 for my $level (reverse 1 .. $max_keys) { 165 my @level_rels; 166 $level_rels[$level] = splice @fk_info, $level, 1; 167 my $count = @{ $level_rels[$level] }; 168 169 for my $sub_level (reverse 1 .. $level-1) { 170 my $total = @{ $fk_info[$sub_level] }; 171 172 $level_rels[$sub_level] = [ 173 splice @{ $fk_info[$sub_level] }, $total-$count, $count 174 ]; 175 } 176 177 while (1) { 178 my @rel = map shift @$_, @level_rels[1..$level]; 179 180 last unless defined $rel[0]; 181 182 my @local_columns = map $_->{fkcolumn_name}, @rel; 183 my @remote_columns = map $_->{pkcolumn_name}, @rel; 184 my $remote_table = $rel[0]->{pktable_name}; 185 186 push @rels, { 187 local_columns => \@local_columns, 188 remote_columns => \@remote_columns, 189 remote_table => $remote_table 190 }; 191 } 192 } 193 194 return \@rels; 195} 196 197sub _table_uniq_info { 198 my ($self, $table) = @_; 199 200 local $SIG{__WARN__} = sub {}; 201 202 my $dbh = $self->schema->storage->dbh; 203 local $dbh->{FetchHashKeyName} = 'NAME_lc'; 204 my $sth = $dbh->prepare(qq{sp_helpconstraint \@objname=@{[ $dbh->quote($table) ]}, \@nomsg='nomsg'}); 205 eval { $sth->execute }; 206 return if $@; 207 208 my $constraints; 209 while (my $row = $sth->fetchrow_hashref) { 210 if (exists $row->{constraint_type}) { 211 my $type = $row->{constraint_type} || ''; 212 if ($type =~ /^unique/i) { 213 my $name = $row->{constraint_name}; 214 push @{$constraints->{$name}}, 215 ( split /,/, $row->{constraint_keys} ); 216 } 217 } else { 218 my $def = $row->{definition} || next; 219 next unless $def =~ /^unique/i; 220 my $name = $row->{name}; 221 my ($keys) = $def =~ /\((.*)\)/; 222 $keys =~ s/\s*//g; 223 my @keys = split /,/ => $keys; 224 push @{$constraints->{$name}}, @keys; 225 } 226 } 227 228 my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints; 229 return \@uniqs; 230} 231 232# get the correct data types, defaults and size 233sub _columns_info_for { 234 my $self = shift; 235 my ($table) = @_; 236 my $result = $self->next::method(@_); 237 238 my $dbh = $self->schema->storage->dbh; 239 my $sth = $dbh->prepare(qq{ 240SELECT c.name name, t.name type, cm.text deflt, c.prec prec, c.scale scale, 241 c.length len 242FROM syscolumns c 243JOIN sysobjects o ON c.id = o.id 244LEFT JOIN systypes t ON c.type = t.type AND c.usertype = t.usertype 245LEFT JOIN syscomments cm 246 ON cm.id = CASE WHEN c.cdefault = 0 THEN c.computedcol ELSE c.cdefault END 247WHERE o.name = @{[ $dbh->quote($table) ]} AND o.type = 'U' 248}); 249 $sth->execute; 250 local $dbh->{FetchHashKeyName} = 'NAME_lc'; 251 my $info = $sth->fetchall_hashref('name'); 252 253 while (my ($col, $res) = each %$result) { 254 my $data_type = $res->{data_type} = $info->{$col}{type}; 255 256 if ($data_type && $data_type =~ /^timestamp\z/i) { 257 $res->{inflate_datetime} = 0; 258 } 259 260 if (my $default = $info->{$col}{deflt}) { 261 if ($default =~ /^AS \s+ (\S+)/ix) { 262 my $function = $1; 263 $res->{default_value} = \$function; 264 } 265 elsif ($default =~ /^DEFAULT \s+ (\S+)/ix) { 266 my ($constant_default) = $1 =~ /^['"\[\]]?(.*?)['"\[\]]?\z/; 267 $res->{default_value} = $constant_default; 268 } 269 } 270 271# XXX we need to handle "binary precision" for FLOAT(X) 272# (see: http://msdn.microsoft.com/en-us/library/aa258876(SQL.80).aspx ) 273 if (my $data_type = $res->{data_type}) { 274 if ($data_type =~ /^(?:text|unitext|image|bigint|int|integer|smallint|tinyint|real|double|double precision|float|date|time|datetime|smalldatetime|money|smallmoney|timestamp|bit)\z/i) { 275 delete $res->{size}; 276 } 277 elsif ($data_type =~ /^(?:numeric|decimal)\z/i) { 278 $res->{size} = [ $info->{$col}{prec}, $info->{$col}{scale} ]; 279 } 280 elsif ($data_type =~ /^(?:unichar|univarchar)\z/i) { 281 $res->{size} /= 2; 282 } 283 } 284 } 285 286 return $result; 287} 288 289sub _extra_column_info { 290 my ($self, $info) = @_; 291 my %extra_info; 292 293 my ($table, $column) = @$info{qw/TABLE_NAME COLUMN_NAME/}; 294 295 my $dbh = $self->schema->storage->dbh; 296 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) ]}}); 297 $sth->execute(); 298 299 if ($sth->fetchrow_array) { 300 $extra_info{is_auto_increment} = 1; 301 } 302 303 return \%extra_info; 304} 305 306=head1 SEE ALSO 307 308L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, 309L<DBIx::Class::Schema::Loader::DBI> 310 311=head1 AUTHOR 312 313See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. 314 315=head1 LICENSE 316 317This library is free software; you can redistribute it and/or modify it under 318the same terms as Perl itself. 319 320=cut 321 3221; 323